code:
/* srfi-14.c --- SRFI-14 procedures for Guile
 *
 * Copyright (C) 2001, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

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

#include <string.h>
#include <unictype.h>

#include "libguile.h"
#include "libguile/srfi-14.h"
#include "libguile/strings.h"
#include "libguile/chars.h"

/* Include the pre-computed standard charset data.  */
#include "libguile/srfi-14.i.c"

scm_t_char_range cs_full_ranges[] = {
  {0x0000, SCM_CODEPOINT_SURROGATE_START - 1}
  ,
  {SCM_CODEPOINT_SURROGATE_END + 1, SCM_CODEPOINT_MAX}
};

scm_t_char_set cs_full = {
  2,
  cs_full_ranges
};

#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))

#define SCM_CHARSET_SET(cs, idx)                        \
  scm_i_charset_set (SCM_CHARSET_DATA (cs), idx)

#define SCM_CHARSET_UNSET(cs, idx)                      \
  scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx)

/* Smob type code for character sets.  */
int scm_tc16_charset = 0;
int scm_tc16_charset_cursor = 0;

/* True if N exists in charset CS.  */
int
scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n)
{
  size_t i;

  i = 0;
  while (i < cs->len)
    {
      if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
        return 1;
      i++;
    }

  return 0;
}

/* Put N into charset CS.  */
void
scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
{
  size_t i;
  size_t len;

  len = cs->len;

  i = 0;
  while (i < len)
    {
      /* Already in this range  */
      if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
        {
          return;
        }

      if (n == cs->ranges[i].lo - 1)
        {
          /* This char is one below the current range. */
          if (i > 0 && cs->ranges[i - 1].hi + 1 == n)
            {
              /* It is also one above the previous range.  */
              /* This is an impossible condition: in the previous
                 iteration, the test for 'one above the current range'
                 should already have inserted the character here.  */
              abort ();
            }
          else
            {
              /* Expand the range down by one.  */
              cs->ranges[i].lo = n;
              return;
            }
        }
      else if (n == cs->ranges[i].hi + 1)
        {
          /* This char is one above the current range.  */
          if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n)
            {
              /* It is also one below the next range, so combine them.  */
              cs->ranges[i].hi = cs->ranges[i + 1].hi;
              if (i < len - 2)
                memmove (cs->ranges + (i + 1), cs->ranges + (i + 2),
                         sizeof (scm_t_char_range) * (len - i - 2));
              cs->ranges = scm_gc_realloc (cs->ranges,
                                           sizeof (scm_t_char_range) * len,
                                           sizeof (scm_t_char_range) * (len -
                                                                        1),
                                           "character-set");
              cs->len = len - 1;
              return;
            }
          else
            {
              /* Expand the range up by one.  */
              cs->ranges[i].hi = n;
              return;
            }
        }
      else if (n < cs->ranges[i].lo - 1)
        {
          /* This is a new range below the current one.  */
          cs->ranges = scm_gc_realloc (cs->ranges,
                                       sizeof (scm_t_char_range) * len,
                                       sizeof (scm_t_char_range) * (len + 1),
                                       "character-set");
          memmove (cs->ranges + (i + 1), cs->ranges + i,
                   sizeof (scm_t_char_range) * (len - i));
          cs->ranges[i].lo = n;
          cs->ranges[i].hi = n;
          cs->len = len + 1;
          return;
        }

      i++;
    }

  /* This is a new range above all previous ranges.  */
  if (len == 0)
    {
      cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
    }
  else
    {
      cs->ranges = scm_gc_realloc (cs->ranges,
                                   sizeof (scm_t_char_range) * len,
                                   sizeof (scm_t_char_range) * (len + 1),
                                   "character-set");
    }
  cs->ranges[len].lo = n;
  cs->ranges[len].hi = n;
  cs->len = len + 1;

  return;
}

/* Put LO to HI inclusive into charset CS.  */
static void
scm_i_charset_set_range (scm_t_char_set *cs, scm_t_wchar lo, scm_t_wchar hi)
{
  size_t i;

  i = 0;
  while (i < cs->len)
    {
      /* Already in this range  */
      if (cs->ranges[i].lo <= lo && cs->ranges[i].hi >= hi)
        return;

      /* cur:       +---+
         new: +---+
      */
      if (cs->ranges[i].lo - 1 > hi)
        {
          /* Add a new range below the current one.  */
          cs->ranges = scm_gc_realloc (cs->ranges,
                                       sizeof (scm_t_char_range) * cs->len,
                                       sizeof (scm_t_char_range) * (cs->len + 1),
                                       "character-set");
          memmove (cs->ranges + (i + 1), cs->ranges + i,
                   sizeof (scm_t_char_range) * (cs->len - i));
          cs->ranges[i].lo = lo;
          cs->ranges[i].hi = hi;
          cs->len += 1;
          return;
        }

      /* cur:      +---+  or     +---+  or    +---+
         new: +---+          +---+         +---+
      */
      if (cs->ranges[i].lo > lo
          && (cs->ranges[i].lo - 1 <= hi && cs->ranges[i].hi >= hi))
        {
          cs->ranges[i].lo = lo;
          return;
        }

      /* cur: +---+    or +---+     or +---+
         new:   +---+         +---+         +---+
      */
      else if (cs->ranges[i].hi + 1 >= lo && cs->ranges[i].hi < hi)
        {
          if (cs->ranges[i].lo > lo)
            cs->ranges[i].lo = lo;
          if (cs->ranges[i].hi < hi)
            cs->ranges[i].hi = hi;
          while (i < cs->len - 1)
            {
              /* cur: --+    +---+
                 new: -----+
              */
              if (cs->ranges[i + 1].lo - 1 > hi)
                break;

              /* cur: --+   +---+  or  --+  +---+  or --+ +--+
                 new: -----+           ------+        ---------+
              */
              /* Combine this range with the previous one.  */
              if (cs->ranges[i + 1].hi > hi)
                cs->ranges[i].hi = cs->ranges[i + 1].hi;
              if (i + 1 < cs->len)
                memmove (cs->ranges + i + 1, cs->ranges + i + 2,
                         sizeof (scm_t_char_range) * (cs->len - i - 2));
              cs->ranges = scm_gc_realloc (cs->ranges,
                                           sizeof (scm_t_char_range) * cs->len,
                                           sizeof (scm_t_char_range) * (cs->len - 1),
                                           "character-set");
              cs->len -= 1;
            }
          return;
        }
      i ++;
    }

  /* This is a new range above all previous ranges.  */
  if (cs->len == 0)
    {
      cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
    }
  else
    {
      cs->ranges = scm_gc_realloc (cs->ranges,
                                   sizeof (scm_t_char_range) * cs->len,
                                   sizeof (scm_t_char_range) * (cs->len + 1),
                                   "character-set");
    }
  cs->len += 1;
  cs->ranges[cs->len - 1].lo = lo;
  cs->ranges[cs->len - 1].hi = hi;

  return;
}

/* If N is in charset CS, remove it.  */
void
scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
{
  size_t i;
  size_t len;

  len = cs->len;

  i = 0;
  while (i < len)
    {
      if (n < cs->ranges[i].lo)
        /* Not in this set.  */
        return;

      if (n == cs->ranges[i].lo && n == cs->ranges[i].hi)
        {
          /* Remove this one-character range.  */
          if (len == 1)
            {
              scm_gc_free (cs->ranges,
                           sizeof (scm_t_char_range) * cs->len,
                           "character-set");
              cs->ranges = NULL;
              cs->len = 0;
              return;
            }
          else if (i < len - 1)
            {
              memmove (cs->ranges + i, cs->ranges + (i + 1),
                       sizeof (scm_t_char_range) * (len - i - 1));
              cs->ranges = scm_gc_realloc (cs->ranges,
                                           sizeof (scm_t_char_range) * len,
                                           sizeof (scm_t_char_range) * (len -
                                                                        1),
                                           "character-set");
              cs->len = len - 1;
              return;
            }
          else if (i == len - 1)
            {
              cs->ranges = scm_gc_realloc (cs->ranges,
                                           sizeof (scm_t_char_range) * len,
                                           sizeof (scm_t_char_range) * (len -
                                                                        1),
                                           "character-set");
              cs->len = len - 1;
              return;
            }
        }
      else if (n == cs->ranges[i].lo)
        {
          /* Shrink this range from the left.  */
          cs->ranges[i].lo = n + 1;
          return;
        }
      else if (n == cs->ranges[i].hi)
        {
          /* Shrink this range from the right.  */
          cs->ranges[i].hi = n - 1;
          return;
        }
      else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi)
        {
          /* Split this range into two pieces.  */
          cs->ranges = scm_gc_realloc (cs->ranges,
                                       sizeof (scm_t_char_range) * len,
                                       sizeof (scm_t_char_range) * (len + 1),
                                       "character-set");
          if (i < len - 1)
            memmove (cs->ranges + (i + 2), cs->ranges + (i + 1),
                     sizeof (scm_t_char_range) * (len - i - 1));
          cs->ranges[i + 1].hi = cs->ranges[i].hi;
          cs->ranges[i + 1].lo = n + 1;
          cs->ranges[i].hi = n - 1;
          cs->len = len + 1;
          return;
        }

      i++;
    }

  /* This value is above all ranges, so do nothing here.  */
  return;
}

static int
charsets_equal (scm_t_char_set *a, scm_t_char_set *b)
{
  if (a->len != b->len)
    return 0;

  if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0)
    return 0;

  return 1;
}

/* Return true if every character in A is also in B.  */
static int
charsets_leq (scm_t_char_set *a, scm_t_char_set *b)
{
  size_t i = 0, j = 0;
  scm_t_wchar alo, ahi;

  if (a->len == 0)
    return 1;
  if (b->len == 0)
    return 0;
  while (i < a->len)
    {
      alo = a->ranges[i].lo;
      ahi = a->ranges[i].hi;
      while (b->ranges[j].hi < alo)
        {
          if (j < b->len - 1)
            j++;
          else
            return 0;
        }
      if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi)
        return 0;
      i++;
    }

  return 1;
}

/* Merge B into A. */
static void
charsets_union (scm_t_char_set *a, scm_t_char_set *b)
{
  size_t i = 0;
  scm_t_wchar blo, bhi;

  if (b->len == 0)
    return;

  if (a->len == 0)
    {
      a->len = b->len;
      a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len,
                                 "character-set");
      memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len);
      return;
    }

  while (i < b->len)
    {
      blo = b->ranges[i].lo;
      bhi = b->ranges[i].hi;
      scm_i_charset_set_range (a, blo, bhi);

      i++;
    }

  return;
}

/* Remove elements not both in A and B from A. */
static void
charsets_intersection (scm_t_char_set *a, scm_t_char_set *b)
{
  size_t i = 0;
  scm_t_wchar blo, bhi, n;
  scm_t_char_set *c;

  if (a->len == 0)
    return;

  if (b->len == 0)
    {
      scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
                   "character-set");
      a->len = 0;
      return;
    }

  c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set));
  c->len = 0;
  c->ranges = NULL;

  while (i < b->len)
    {
      blo = b->ranges[i].lo;
      bhi = b->ranges[i].hi;
      for (n = blo; n <= bhi; n++)
        if (scm_i_charset_get (a, n))
          scm_i_charset_set (c, n);
      i++;
    }
  scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
               "character-set");

  a->len = c->len;
  if (c->len != 0)
    a->ranges = c->ranges;
  else
    a->ranges = NULL;
  free (c);
  return;
}

#define SCM_ADD_RANGE(low, high)                        \
  do {                                                  \
    p->ranges[idx].lo = (low);                          \
    p->ranges[idx++].hi = (high);                       \
  } while (0)
#define SCM_ADD_RANGE_SKIP_SURROGATES(low, high)                  \
  do {                                                            \
    p->ranges[idx].lo = (low);                                    \
    p->ranges[idx++].hi = SCM_CODEPOINT_SURROGATE_START - 1;      \
    p->ranges[idx].lo = SCM_CODEPOINT_SURROGATE_END + 1;          \
    p->ranges[idx++].hi = (high);                                 \
  } while (0)

/* Make P the compelement of Q.  */
static void
charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
{
  int k, idx;

  idx = 0;
  if (q->len == 0)
    {
      /* Fill with all valid codepoints.  */
      p->len = 2;
      p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2,
                                 "character-set");
      SCM_ADD_RANGE_SKIP_SURROGATES (0, SCM_CODEPOINT_MAX);
      return;
    }

  if (p->len > 0)
    scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
                 "character-set");

  /* Count the number of ranges needed for the output.  */
  p->len = 0;
  if (q->ranges[0].lo > 0)
    p->len++;
  if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
    p->len++;
  p->len += q->len;
  p->ranges =
    (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len,
                                        "character-set");
  if (q->ranges[0].lo > 0)
    {
      if (q->ranges[0].lo > SCM_CODEPOINT_SURROGATE_END)
        SCM_ADD_RANGE_SKIP_SURROGATES (0, q->ranges[0].lo - 1);
      else
        SCM_ADD_RANGE (0, q->ranges[0].lo - 1);
    }
  for (k = 1; k < q->len; k++)
    {
      if (q->ranges[k - 1].hi < SCM_CODEPOINT_SURROGATE_START
          && q->ranges[k].lo - 1 > SCM_CODEPOINT_SURROGATE_END)
        SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
      else
        SCM_ADD_RANGE (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
    }
  if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
    {
      if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_SURROGATE_START)
        SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
      else
        SCM_ADD_RANGE (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
    }
  return;
}
#undef SCM_ADD_RANGE
#undef SCM_ADD_RANGE_SKIP_SURROGATES

/* Replace A with elements only found in one of A or B.  */
static void
charsets_xor (scm_t_char_set *a, scm_t_char_set *b)
{
  size_t i = 0;
  scm_t_wchar blo, bhi, n;

  if (b->len == 0)
    {
      return;
    }

  if (a->len == 0)
    {
      a->ranges =
        (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) *
                                            b->len, "character-set");
      a->len = b->len;
      memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len);
      return;
    }

  while (i < b->len)
    {
      blo = b->ranges[i].lo;
      bhi = b->ranges[i].hi;
      for (n = blo; n <= bhi; n++)
        {
          if (scm_i_charset_get (a, n))
            scm_i_charset_unset (a, n);
          else
            scm_i_charset_set (a, n);
        }

      i++;
    }
  return;
}

/* Smob print hook for character sets.  */
static int
charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  size_t i;
  int first = 1;
  scm_t_char_set *p;
  const size_t max_ranges_to_print = 50;

  p = SCM_CHARSET_DATA (charset);

  scm_puts ("#<charset {", port);
  for (i = 0; i < p->len; i++)
    {
      if (first)
        first = 0;
      else
        scm_puts (" ", port);
      scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
      if (p->ranges[i].lo != p->ranges[i].hi)
        {
          scm_puts ("..", port);
          scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
        }
      if (i >= max_ranges_to_print)
        {
          /* Too many to print here.  Quit early.  */
          scm_puts (" ...", port);
          break;
        }
    }
  scm_puts ("}>", port);
  return 1;
}

/* Smob print hook for character sets cursors.  */
static int
charset_cursor_print (SCM cursor, SCM port,
                      scm_print_state *pstate SCM_UNUSED)
{
  scm_t_char_set_cursor *cur;

  cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);

  scm_puts ("#<charset-cursor ", port);
  if (cur->range == (size_t) (-1))
    scm_puts ("(empty)", port);
  else
    {
      scm_write (scm_from_size_t (cur->range), port);
      scm_puts (":", port);
      scm_write (scm_from_int32 (cur->n), port);
    }
  scm_puts (">", port);
  return 1;
}

/* Create a new, empty character set.  */
static SCM
make_char_set (const char *func_name)
{
  scm_t_char_set *p;

  p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set");
  memset (p, 0, sizeof (scm_t_char_set));
  SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
}

SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
	    "otherwise.")
#define FUNC_NAME s_scm_char_set_p
{
  return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
	    (SCM char_sets),
	    "Return @code{#t} if all given character sets are equal.")
#define FUNC_NAME s_scm_char_set_eq
{
  int argnum = 1;
  scm_t_char_set *cs1_data = NULL;

  SCM_VALIDATE_REST_ARGUMENT (char_sets);

  while (!scm_is_null (char_sets))
    {
      SCM csi = SCM_CAR (char_sets);
      scm_t_char_set *csi_data;

      SCM_VALIDATE_SMOB (argnum, csi, charset);
      argnum++;
      csi_data = SCM_CHARSET_DATA (csi);
      if (cs1_data == NULL)
        cs1_data = csi_data;
      else if (!charsets_equal (cs1_data, csi_data))
        return SCM_BOOL_F;
      char_sets = SCM_CDR (char_sets);
    }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
	    (SCM char_sets),
	    "Return @code{#t} if every character set @var{cs}i is a subset\n"
	    "of character set @var{cs}i+1.")
#define FUNC_NAME s_scm_char_set_leq
{
  int argnum = 1;
  scm_t_char_set *prev_data = NULL;

  SCM_VALIDATE_REST_ARGUMENT (char_sets);

  while (!scm_is_null (char_sets))
    {
      SCM csi = SCM_CAR (char_sets);
      scm_t_char_set *csi_data;

      SCM_VALIDATE_SMOB (argnum, csi, charset);
      argnum++;
      csi_data = SCM_CHARSET_DATA (csi);
      if (prev_data)
        {
          if (!charsets_leq (prev_data, csi_data))
            return SCM_BOOL_F;
        }
      prev_data = csi_data;
      char_sets = SCM_CDR (char_sets);
    }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
	    (SCM cs, SCM bound),
	    "Compute a hash value for the character set @var{cs}.  If\n"
	    "@var{bound} is given and non-zero, it restricts the\n"
	    "returned value to the range 0 @dots{} @var{bound - 1}.")
#define FUNC_NAME s_scm_char_set_hash
{
  const unsigned long default_bnd = 871;
  unsigned long bnd;
  scm_t_char_set *p;
  unsigned long val = 0;
  int k;
  scm_t_wchar c;

  SCM_VALIDATE_SMOB (1, cs, charset);

  if (SCM_UNBNDP (bound))
    bnd = default_bnd;
  else
    {
      bnd = scm_to_ulong (bound);
      if (bnd == 0)
        bnd = default_bnd;
    }

  p = SCM_CHARSET_DATA (cs);
  for (k = 0; k < p->len; k++)
    {
      for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++)
        val = c + (val << 1);
    }
  return scm_from_ulong (val % bnd);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
            (SCM cs), "Return a cursor into the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_cursor
{
  scm_t_char_set *cs_data;
  scm_t_char_set_cursor *cur_data;

  SCM_VALIDATE_SMOB (1, cs, charset);
  cs_data = SCM_CHARSET_DATA (cs);
  cur_data =
    (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor),
                                             "charset-cursor");
  if (cs_data->len == 0)
    {
      cur_data->range = (size_t) (-1);
      cur_data->n = 0;
    }
  else
    {
      cur_data->range = 0;
      cur_data->n = cs_data->ranges[0].lo;
    }
  SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
            (SCM cs, SCM cursor),
            "Return the character at the current cursor position\n"
            "@var{cursor} in the character set @var{cs}.  It is an error to\n"
            "pass a cursor for which @code{end-of-char-set?} returns true.")
#define FUNC_NAME s_scm_char_set_ref
{
  scm_t_char_set *cs_data;
  scm_t_char_set_cursor *cur_data;
  size_t i;

  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_SMOB (2, cursor, charset_cursor);

  cs_data = SCM_CHARSET_DATA (cs);
  cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);

  /* Validate that this cursor is still true.  */
  i = cur_data->range;
  if (i == (size_t) (-1)
      || i >= cs_data->len
      || cur_data->n < cs_data->ranges[i].lo
      || cur_data->n > cs_data->ranges[i].hi)
    SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
  return SCM_MAKE_CHAR (cur_data->n);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
            (SCM cs, SCM cursor),
            "Advance the character set cursor @var{cursor} to the next\n"
            "character in the character set @var{cs}.  It is an error if the\n"
            "cursor given satisfies @code{end-of-char-set?}.")
#define FUNC_NAME s_scm_char_set_cursor_next
{
  scm_t_char_set *cs_data;
  scm_t_char_set_cursor *cur_data;
  size_t i;

  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_SMOB (2, cursor, charset_cursor);

  cs_data = SCM_CHARSET_DATA (cs);
  cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);

  /* Validate that this cursor is still true.  */
  i = cur_data->range;
  if (i == (size_t) (-1)
      || i >= cs_data->len
      || cur_data->n < cs_data->ranges[i].lo
      || cur_data->n > cs_data->ranges[i].hi)
    SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
  /* Increment the cursor.  */
  if (cur_data->n == cs_data->ranges[i].hi)
    {
      if (i + 1 < cs_data->len)
        {
          cur_data->range = i + 1;
          cur_data->n = cs_data->ranges[i + 1].lo;
        }
      else
        {
          /* This is the end of the road.  */
          cur_data->range = (size_t) (-1);
          cur_data->n = 0;
        }
    }
  else
    {
      cur_data->n = cur_data->n + 1;
    }

  return cursor;
}
#undef FUNC_NAME

SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
            (SCM cursor),
            "Return @code{#t} if @var{cursor} has reached the end of a\n"
            "character set, @code{#f} otherwise.")
#define FUNC_NAME s_scm_end_of_char_set_p
{
  scm_t_char_set_cursor *cur_data;
  SCM_VALIDATE_SMOB (1, cursor, charset_cursor);

  cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
  if (cur_data->range == (size_t) (-1))
    return SCM_BOOL_T;

  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
            (SCM kons, SCM knil, SCM cs),
            "Fold the procedure @var{kons} over the character set @var{cs},\n"
            "initializing it with @var{knil}.")
#define FUNC_NAME s_scm_char_set_fold
{
  scm_t_char_set *cs_data;
  int k;
  scm_t_wchar n;

  SCM_VALIDATE_PROC (1, kons);
  SCM_VALIDATE_SMOB (3, cs, charset);

  cs_data = SCM_CHARSET_DATA (cs);

  if (cs_data->len == 0)
    return knil;

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil);
      }
  return knil;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
	    (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
	    "This is a fundamental constructor for character sets.\n"
	    "@itemize @bullet\n"
	    "@item @var{g} is used to generate a series of ``seed'' values\n"
	    "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
	    "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
	    "@item @var{p} tells us when to stop -- when it returns true\n"
	    "when applied to one of the seed values.\n"
	    "@item @var{f} maps each seed value to a character. These\n"
	    "characters are added to the base character set @var{base_cs} to\n"
	    "form the result; @var{base_cs} defaults to the empty set.\n"
	    "@end itemize")
#define FUNC_NAME s_scm_char_set_unfold
{
  SCM result, tmp;

  SCM_VALIDATE_PROC (1, p);
  SCM_VALIDATE_PROC (2, f);
  SCM_VALIDATE_PROC (3, g);
  if (!SCM_UNBNDP (base_cs))
    {
      SCM_VALIDATE_SMOB (5, base_cs, charset);
      result = scm_char_set_copy (base_cs);
    }
  else
    result = make_char_set (FUNC_NAME);

  tmp = scm_call_1 (p, seed);
  while (scm_is_false (tmp))
    {
      SCM ch = scm_call_1 (f, seed);
      if (!SCM_CHARP (ch))
	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
      SCM_CHARSET_SET (result, SCM_CHAR (ch));

      seed = scm_call_1 (g, seed);
      tmp = scm_call_1 (p, seed);
    }
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
	    (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
	    "This is a fundamental constructor for character sets.\n"
	    "@itemize @bullet\n"
	    "@item @var{g} is used to generate a series of ``seed'' values\n"
	    "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
	    "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
	    "@item @var{p} tells us when to stop -- when it returns true\n"
	    "when applied to one of the seed values.\n"
	    "@item @var{f} maps each seed value to a character. These\n"
	    "characters are added to the base character set @var{base_cs} to\n"
	    "form the result; @var{base_cs} defaults to the empty set.\n"
	    "@end itemize")
#define FUNC_NAME s_scm_char_set_unfold_x
{
  SCM tmp;

  SCM_VALIDATE_PROC (1, p);
  SCM_VALIDATE_PROC (2, f);
  SCM_VALIDATE_PROC (3, g);
  SCM_VALIDATE_SMOB (5, base_cs, charset);

  tmp = scm_call_1 (p, seed);
  while (scm_is_false (tmp))
    {
      SCM ch = scm_call_1 (f, seed);
      if (!SCM_CHARP (ch))
	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
      SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));

      seed = scm_call_1 (g, seed);
      tmp = scm_call_1 (p, seed);
    }
  return base_cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
            (SCM proc, SCM cs),
            "Apply @var{proc} to every character in the character set\n"
            "@var{cs}.  The return value is not specified.")
#define FUNC_NAME s_scm_char_set_for_each
{
  scm_t_char_set *cs_data;
  int k;
  scm_t_wchar n;

  SCM_VALIDATE_PROC (1, proc);
  SCM_VALIDATE_SMOB (2, cs, charset);

  cs_data = SCM_CHARSET_DATA (cs);

  if (cs_data->len == 0)
    return SCM_UNSPECIFIED;

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        scm_call_1 (proc, SCM_MAKE_CHAR (n));
      }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
	    (SCM proc, SCM cs),
	    "Map the procedure @var{proc} over every character in @var{cs}.\n"
	    "@var{proc} must be a character -> character procedure.")
#define FUNC_NAME s_scm_char_set_map
{
  SCM result;
  int k;
  scm_t_char_set *cs_data;
  scm_t_wchar n;

  SCM_VALIDATE_PROC (1, proc);
  SCM_VALIDATE_SMOB (2, cs, charset);

  result = make_char_set (FUNC_NAME);
  cs_data = SCM_CHARSET_DATA (cs);

  if (cs_data->len == 0)
    return result;

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n));
        if (!SCM_CHARP (ch))
          SCM_MISC_ERROR ("procedure ~S returned non-char",
                          scm_list_1 (proc));
        SCM_CHARSET_SET (result, SCM_CHAR (ch));
      }
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
	    (SCM cs),
	    "Return a newly allocated character set containing all\n"
	    "characters in @var{cs}.")
#define FUNC_NAME s_scm_char_set_copy
{
  SCM ret;
  scm_t_char_set *p1, *p2;

  SCM_VALIDATE_SMOB (1, cs, charset);
  ret = make_char_set (FUNC_NAME);
  p1 = SCM_CHARSET_DATA (cs);
  p2 = SCM_CHARSET_DATA (ret);
  p2->len = p1->len;

  if (p1->len == 0)
    p2->ranges = NULL;
  else
    {
      p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len,
                                  "character-set");
      memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len);
    }

  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
	    (SCM rest),
	    "Return a character set containing all given characters.")
#define FUNC_NAME s_scm_char_set
{
  SCM cs;
  int argnum = 1;

  SCM_VALIDATE_REST_ARGUMENT (rest);
  cs = make_char_set (FUNC_NAME);
  while (!scm_is_null (rest))
    {
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
      argnum++;
      rest = SCM_CDR (rest);
      SCM_CHARSET_SET (cs, c);
    }
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
	    (SCM list, SCM base_cs),
	    "Convert the character list @var{list} to a character set.  If\n"
	    "the character set @var{base_cs} is given, the character in this\n"
	    "set are also included in the result.")
#define FUNC_NAME s_scm_list_to_char_set
{
  SCM cs;

  SCM_VALIDATE_LIST (1, list);
  if (SCM_UNBNDP (base_cs))
    cs = make_char_set (FUNC_NAME);
  else
    {
      SCM_VALIDATE_SMOB (2, base_cs, charset);
      cs = scm_char_set_copy (base_cs);
    }
  while (!scm_is_null (list))
    {
      SCM chr = SCM_CAR (list);
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (0, chr, c);
      list = SCM_CDR (list);

      SCM_CHARSET_SET (cs, c);
    }
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
            (SCM list, SCM base_cs),
            "Convert the character list @var{list} to a character set.  The\n"
            "characters are added to @var{base_cs} and @var{base_cs} is\n"
            "returned.")
#define FUNC_NAME s_scm_list_to_char_set_x
{
  SCM_VALIDATE_LIST (1, list);
  SCM_VALIDATE_SMOB (2, base_cs, charset);
  while (!scm_is_null (list))
    {
      SCM chr = SCM_CAR (list);
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (0, chr, c);
      list = SCM_CDR (list);

      SCM_CHARSET_SET (base_cs, c);
    }
  return base_cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
	    (SCM str, SCM base_cs),
	    "Convert the string @var{str} to a character set.  If the\n"
	    "character set @var{base_cs} is given, the characters in this\n"
	    "set are also included in the result.")
#define FUNC_NAME s_scm_string_to_char_set
{
  SCM cs;
  size_t k = 0, len;

  SCM_VALIDATE_STRING (1, str);
  if (SCM_UNBNDP (base_cs))
    cs = make_char_set (FUNC_NAME);
  else
    {
      SCM_VALIDATE_SMOB (2, base_cs, charset);
      cs = scm_char_set_copy (base_cs);
    }
  len = scm_i_string_length (str);
  while (k < len)
    {
      scm_t_wchar c = scm_i_string_ref (str, k++);
      SCM_CHARSET_SET (cs, c);
    }
  scm_remember_upto_here_1 (str);
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
            (SCM str, SCM base_cs),
            "Convert the string @var{str} to a character set.  The\n"
            "characters from the string are added to @var{base_cs}, and\n"
            "@var{base_cs} is returned.")
#define FUNC_NAME s_scm_string_to_char_set_x
{
  size_t k = 0, len;

  SCM_VALIDATE_STRING (1, str);
  SCM_VALIDATE_SMOB (2, base_cs, charset);
  len = scm_i_string_length (str);
  while (k < len)
    {
      scm_t_wchar c = scm_i_string_ref (str, k++);
      SCM_CHARSET_SET (base_cs, c);
    }
  scm_remember_upto_here_1 (str);
  return base_cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
	    (SCM pred, SCM cs, SCM base_cs),
	    "Return a character set containing every character from @var{cs}\n"
	    "so that it satisfies @var{pred}.  If provided, the characters\n"
	    "from @var{base_cs} are added to the result.")
#define FUNC_NAME s_scm_char_set_filter
{
  SCM ret;
  int k;
  scm_t_wchar n;
  scm_t_char_set *p;

  SCM_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);
  if (!SCM_UNBNDP (base_cs))
    {
      SCM_VALIDATE_SMOB (3, base_cs, charset);
      ret = scm_char_set_copy (base_cs);
    }
  else
    ret = make_char_set (FUNC_NAME);

  p = SCM_CHARSET_DATA (cs);

  if (p->len == 0)
    return ret;

  for (k = 0; k < p->len; k++)
    for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
      {
        SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));

        if (scm_is_true (res))
          SCM_CHARSET_SET (ret, n);
      }
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
	    (SCM pred, SCM cs, SCM base_cs),
	    "Return a character set containing every character from @var{cs}\n"
	    "so that it satisfies @var{pred}.  The characters are added to\n"
	    "@var{base_cs} and @var{base_cs} is returned.")
#define FUNC_NAME s_scm_char_set_filter_x
{
  int k;
  scm_t_wchar n;
  scm_t_char_set *p;

  SCM_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);
  SCM_VALIDATE_SMOB (3, base_cs, charset);
  p = SCM_CHARSET_DATA (cs);
  if (p->len == 0)
    return base_cs;

  for (k = 0; k < p->len; k++)
    for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
      {
        SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));

        if (scm_is_true (res))
          SCM_CHARSET_SET (base_cs, n);
      }
  return base_cs;
}
#undef FUNC_NAME

/* Return a character set containing all the characters from [LOWER,UPPER),
   giving range errors if ERROR, adding chars from BASE_CS, and recycling
   BASE_CS if REUSE is true.  */
static SCM
scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
                             SCM error, SCM base_cs, int reuse)
{
  SCM cs;
  size_t clower, cupper;

  clower = scm_to_size_t (lower);
  cupper = scm_to_size_t (upper) - 1;
  SCM_ASSERT_RANGE (2, upper, cupper >= clower);
  if (!SCM_UNBNDP (error))
    {
      if (scm_is_true (error))
        {
          SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
          SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
          if (clower < SCM_CODEPOINT_SURROGATE_START
              && cupper > SCM_CODEPOINT_SURROGATE_END)
            scm_error(scm_out_of_range_key,
                      FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
                      scm_list_2 (lower, upper), scm_list_1 (upper));
        }
    }

  if (SCM_UNBNDP (base_cs))
    cs = make_char_set (FUNC_NAME);
  else
    {
      SCM_VALIDATE_SMOB (3, base_cs, charset);
      if (reuse)
        cs = base_cs;
      else
        cs = scm_char_set_copy (base_cs);
    }

  if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
      && (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
    return cs;

  if (clower > SCM_CODEPOINT_MAX)
    clower = SCM_CODEPOINT_MAX;
  if (clower >= SCM_CODEPOINT_SURROGATE_START  && clower <= SCM_CODEPOINT_SURROGATE_END)
    clower = SCM_CODEPOINT_SURROGATE_END + 1;
  if (cupper > SCM_CODEPOINT_MAX)
    cupper = SCM_CODEPOINT_MAX;
  if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
    cupper = SCM_CODEPOINT_SURROGATE_START - 1;
  if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
    {
      scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, SCM_CODEPOINT_SURROGATE_START - 1);
      scm_i_charset_set_range (SCM_CHARSET_DATA (cs), SCM_CODEPOINT_SURROGATE_END + 1, cupper);
    }
  else
    scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, cupper);
  return cs;
}

SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
	    (SCM lower, SCM upper, SCM error, SCM base_cs),
	    "Return a character set containing all characters whose\n"
	    "character codes lie in the half-open range\n"
	    "[@var{lower},@var{upper}).\n"
	    "\n"
	    "If @var{error} is a true value, an error is signalled if the\n"
	    "specified range contains characters which are not valid\n"
	    "Unicode code points.  If @var{error} is @code{#f},\n"
	    "these characters are silently left out of the resultung\n"
	    "character set.\n"
	    "\n"
	    "The characters in @var{base_cs} are added to the result, if\n"
	    "given.")
#define FUNC_NAME s_scm_ucs_range_to_char_set
{
  return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
                                      error, base_cs, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
	    (SCM lower, SCM upper, SCM error, SCM base_cs),
	    "Return a character set containing all characters whose\n"
	    "character codes lie in the half-open range\n"
	    "[@var{lower},@var{upper}).\n"
	    "\n"
	    "If @var{error} is a true value, an error is signalled if the\n"
	    "specified range contains characters which are not contained in\n"
	    "the implemented character range.  If @var{error} is @code{#f},\n"
	    "these characters are silently left out of the resultung\n"
	    "character set.\n"
	    "\n"
	    "The characters are added to @var{base_cs} and @var{base_cs} is\n"
	    "returned.")
#define FUNC_NAME s_scm_ucs_range_to_char_set_x
{
  SCM_VALIDATE_SMOB (4, base_cs, charset);
  return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
                                      error, base_cs, 1);
}
#undef FUNC_NAME

SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0,
	    (SCM x),
	    "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.")
#define FUNC_NAME s_scm_to_char_set
{
  if (scm_is_string (x))
    return scm_string_to_char_set (x, SCM_UNDEFINED);
  else if (SCM_CHARP (x))
    return scm_char_set (scm_list_1 (x));
  else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x))
    return x;
  else
    scm_wrong_type_arg (NULL, 0, x);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
	    (SCM cs),
	    "Return the number of elements in character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_size
{
  int k, count = 0;
  scm_t_char_set *cs_data;

  SCM_VALIDATE_SMOB (1, cs, charset);
  cs_data = SCM_CHARSET_DATA (cs);

  if (cs_data->len == 0)
    return scm_from_int (0);

  for (k = 0; k < cs_data->len; k++)
    count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1;

  return scm_from_int (count);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
	    (SCM pred, SCM cs),
	    "Return the number of the elements int the character set\n"
	    "@var{cs} which satisfy the predicate @var{pred}.")
#define FUNC_NAME s_scm_char_set_count
{
  int k, count = 0;
  scm_t_wchar n;
  scm_t_char_set *cs_data;

  SCM_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);
  cs_data = SCM_CHARSET_DATA (cs);
  if (cs_data->len == 0)
    return scm_from_int (0);

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
        if (scm_is_true (res))
          count++;
      }
  return SCM_I_MAKINUM (count);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
	    (SCM cs),
	    "Return a list containing the elements of the character set\n"
	    "@var{cs}.")
#define FUNC_NAME s_scm_char_set_to_list
{
  int k;
  scm_t_wchar n;
  SCM result = SCM_EOL;
  scm_t_char_set *p;

  SCM_VALIDATE_SMOB (1, cs, charset);
  p = SCM_CHARSET_DATA (cs);
  if (p->len == 0)
    return SCM_EOL;

  for (k = p->len - 1; k >= 0; k--)
    for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--)
      result = scm_cons (SCM_MAKE_CHAR (n), result);
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
	    (SCM cs),
	    "Return a string containing the elements of the character set\n"
	    "@var{cs}.  The order in which the characters are placed in the\n"
	    "string is not defined.")
#define FUNC_NAME s_scm_char_set_to_string
{
  int k;
  int count = 0;
  int idx = 0;
  int wide = 0;
  SCM result;
  scm_t_wchar n;
  scm_t_char_set *cs_data;
  char *buf;
  scm_t_wchar *wbuf;

  SCM_VALIDATE_SMOB (1, cs, charset);
  cs_data = SCM_CHARSET_DATA (cs);
  if (cs_data->len == 0)
    return scm_nullstr;

  if (cs_data->ranges[cs_data->len - 1].hi > 255)
    wide = 1;

  count = scm_to_int (scm_char_set_size (cs));
  if (wide)
    result = scm_i_make_wide_string (count, &wbuf);
  else
    result = scm_i_make_string (count, &buf);

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        if (wide)
          wbuf[idx++] = n;
        else
          buf[idx++] = n;
      }
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
	    (SCM cs, SCM ch),
	    "Return @code{#t} iff the character @var{ch} is contained in the\n"
	    "character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_contains_p
{
  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_CHAR (2, ch);
  return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
	    (SCM pred, SCM cs),
	    "Return a true value if every character in the character set\n"
	    "@var{cs} satisfies the predicate @var{pred}.")
#define FUNC_NAME s_scm_char_set_every
{
  int k;
  scm_t_wchar n;
  SCM res = SCM_BOOL_T;
  scm_t_char_set *cs_data;

  SCM_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);

  cs_data = SCM_CHARSET_DATA (cs);
  if (cs_data->len == 0)
    return SCM_BOOL_T;

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
        if (scm_is_false (res))
          return res;
      }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
	    (SCM pred, SCM cs),
	    "Return a true value if any character in the character set\n"
	    "@var{cs} satisfies the predicate @var{pred}.")
#define FUNC_NAME s_scm_char_set_any
{
  int k;
  scm_t_wchar n;
  scm_t_char_set *cs_data;

  SCM_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);

  cs_data = SCM_CHARSET_DATA (cs);
  if (cs_data->len == 0)
    return SCM_BOOL_T;

  for (k = 0; k < cs_data->len; k++)
    for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
      {
        SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
        if (scm_is_true (res))
          return res;
      }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
            (SCM cs, SCM rest),
            "Add all character arguments to the first argument, which must\n"
            "be a character set.")
#define FUNC_NAME s_scm_char_set_adjoin
{
  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);
  cs = scm_char_set_copy (cs);

  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (1, chr, c);
      rest = SCM_CDR (rest);

      SCM_CHARSET_SET (cs, c);
    }
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
            (SCM cs, SCM rest),
            "Delete all character arguments from the first argument, which\n"
            "must be a character set.")
#define FUNC_NAME s_scm_char_set_delete
{
  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);
  cs = scm_char_set_copy (cs);

  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (1, chr, c);
      rest = SCM_CDR (rest);

      SCM_CHARSET_UNSET (cs, c);
    }
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
            (SCM cs, SCM rest),
            "Add all character arguments to the first argument, which must\n"
            "be a character set.")
#define FUNC_NAME s_scm_char_set_adjoin_x
{
  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (1, chr, c);
      rest = SCM_CDR (rest);

      SCM_CHARSET_SET (cs, c);
    }
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
            (SCM cs, SCM rest),
            "Delete all character arguments from the first argument, which\n"
            "must be a character set.")
#define FUNC_NAME s_scm_char_set_delete_x
{
  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      scm_t_wchar c;

      SCM_VALIDATE_CHAR_COPY (1, chr, c);
      rest = SCM_CDR (rest);

      SCM_CHARSET_UNSET (cs, c);
    }
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
            (SCM cs), "Return the complement of the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_complement
{
  SCM res;
  scm_t_char_set *p, *q;

  SCM_VALIDATE_SMOB (1, cs, charset);

  res = make_char_set (FUNC_NAME);
  p = SCM_CHARSET_DATA (res);
  q = SCM_CHARSET_DATA (cs);

  charsets_complement (p, q);
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
	    (SCM rest),
	    "Return the union of all argument character sets.")
#define FUNC_NAME s_scm_char_set_union
{
  int c = 1;
  SCM res;
  scm_t_char_set *p;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  res = make_char_set (FUNC_NAME);
  p = SCM_CHARSET_DATA (res);
  while (!scm_is_null (rest))
    {
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs));
    }
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
	    (SCM rest),
	    "Return the intersection of all argument character sets.")
#define FUNC_NAME s_scm_char_set_intersection
{
  SCM res;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  if (scm_is_null (rest))
    res = make_char_set (FUNC_NAME);
  else
    {
      scm_t_char_set *p;
      int argnum = 2;

      res = scm_char_set_copy (SCM_CAR (rest));
      p = SCM_CHARSET_DATA (res);
      rest = SCM_CDR (rest);

      while (scm_is_pair (rest))
        {
          SCM cs = SCM_CAR (rest);
          scm_t_char_set *cs_data;

          SCM_VALIDATE_SMOB (argnum, cs, charset);
          argnum++;
          cs_data = SCM_CHARSET_DATA (cs);
          rest = SCM_CDR (rest);
          charsets_intersection (p, cs_data);
        }
    }

  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
	    (SCM cs1, SCM rest),
	    "Return the difference of all argument character sets.")
#define FUNC_NAME s_scm_char_set_difference
{
  int c = 2;
  SCM res, compl;
  scm_t_char_set *p, *q;

  SCM_VALIDATE_SMOB (1, cs1, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  res = scm_char_set_copy (cs1);
  p = SCM_CHARSET_DATA (res);
  compl = make_char_set (FUNC_NAME);
  q = SCM_CHARSET_DATA (compl);
  while (!scm_is_null (rest))
    {
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      charsets_complement (q, SCM_CHARSET_DATA (cs));
      charsets_intersection (p, q);
    }
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
	    (SCM rest),
	    "Return the exclusive-or of all argument character sets.")
#define FUNC_NAME s_scm_char_set_xor
{
  SCM res;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  if (scm_is_null (rest))
    res = make_char_set (FUNC_NAME);
  else
    {
      int argnum = 2;
      scm_t_char_set *p;

      res = scm_char_set_copy (SCM_CAR (rest));
      p = SCM_CHARSET_DATA (res);
      rest = SCM_CDR (rest);

      while (scm_is_pair (rest))
        {
          SCM cs = SCM_CAR (rest);
          scm_t_char_set *cs_data;

          SCM_VALIDATE_SMOB (argnum, cs, charset);
          argnum++;
          cs_data = SCM_CHARSET_DATA (cs);
          rest = SCM_CDR (rest);

          charsets_xor (p, cs_data);
        }
    }
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
	    (SCM cs1, SCM rest),
	    "Return the difference and the intersection of all argument\n"
	    "character sets.")
#define FUNC_NAME s_scm_char_set_diff_plus_intersection
{
  int c = 2;
  SCM res1, res2;
  scm_t_char_set *p, *q;

  SCM_VALIDATE_SMOB (1, cs1, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  res1 = scm_char_set_copy (cs1);
  res2 = make_char_set (FUNC_NAME);
  p = SCM_CHARSET_DATA (res1);
  q = SCM_CHARSET_DATA (res2);
  while (!scm_is_null (rest))
    {
      SCM cs = SCM_CAR (rest);
      scm_t_char_set *r;

      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      r = SCM_CHARSET_DATA (cs);

      charsets_union (q, r);
      charsets_intersection (p, r);
      rest = SCM_CDR (rest);
    }
  return scm_values (scm_list_2 (res1, res2));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
            (SCM cs), "Return the complement of the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_complement_x
{
  SCM_VALIDATE_SMOB (1, cs, charset);
  cs = scm_char_set_complement (cs);
  return cs;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
            (SCM cs1, SCM rest),
            "Return the union of all argument character sets.")
#define FUNC_NAME s_scm_char_set_union_x
{
  SCM_VALIDATE_SMOB (1, cs1, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  cs1 = scm_char_set_union (scm_cons (cs1, rest));
  return cs1;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
            (SCM cs1, SCM rest),
            "Return the intersection of all argument character sets.")
#define FUNC_NAME s_scm_char_set_intersection_x
{
  SCM_VALIDATE_SMOB (1, cs1, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
  return cs1;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
            (SCM cs1, SCM rest),
            "Return the difference of all argument character sets.")
#define FUNC_NAME s_scm_char_set_difference_x
{
  SCM_VALIDATE_SMOB (1, cs1, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);

  cs1 = scm_char_set_difference (cs1, rest);
  return cs1;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
	    (SCM cs1, SCM rest),
	    "Return the exclusive-or of all argument character sets.")
#define FUNC_NAME s_scm_char_set_xor_x
{
  /* a side-effecting variant should presumably give consistent results:
     (define a (char-set #\a))
     (char-set-xor a a a) -> char set #\a
     (char-set-xor! a a a) -> char set #\a
   */
  cs1 = scm_char_set_xor (scm_cons (cs1, rest));
  return cs1;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
            "char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2,
                                                     SCM rest),
            "Return the difference and the intersection of all argument\n"
            "character sets.")
#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
{
  SCM diff, intersect;

  diff = scm_char_set_difference (cs1, scm_cons (cs2, rest));
  intersect =
    scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
  cs1 = diff;
  cs2 = intersect;
  return scm_values (scm_list_2 (cs1, cs2));
}
#undef FUNC_NAME

/* Standard character sets.  */

SCM scm_char_set_lower_case;
SCM scm_char_set_upper_case;
SCM scm_char_set_title_case;
SCM scm_char_set_letter;
SCM scm_char_set_digit;
SCM scm_char_set_letter_and_digit;
SCM scm_char_set_graphic;
SCM scm_char_set_printing;
SCM scm_char_set_whitespace;
SCM scm_char_set_iso_control;
SCM scm_char_set_punctuation;
SCM scm_char_set_symbol;
SCM scm_char_set_hex_digit;
SCM scm_char_set_blank;
SCM scm_char_set_ascii;
SCM scm_char_set_empty;
SCM scm_char_set_designated;
SCM scm_char_set_full;

/* Create an empty character set and return it after binding it to NAME.  */
static inline SCM
define_charset (const char *name, const scm_t_char_set *p)
{
  SCM cs;

  SCM_NEWSMOB (cs, scm_tc16_charset, p);
  scm_c_define (name, cs);
  return cs;
}

SCM_DEFINE (scm_sys_char_set_dump, "%char-set-dump", 1, 0, 0, (SCM charset),
            "Returns an association list containing debugging information\n"
            "for @var{charset}. The association list has the following entries."
            "@table @code\n"
            "@item char-set\n"
            "The char-set itself.\n"
            "@item len\n"
            "The number of character ranges the char-set contains\n"
            "@item ranges\n"
            "A list of lists where each sublist a range of code points\n"
            "and their associated characters"
            "@end table")
#define FUNC_NAME s_scm_sys_char_set_dump
{
  SCM e1, e2, e3;
  SCM ranges = SCM_EOL, elt;
  size_t i;
  scm_t_char_set *cs;
  char codepoint_string_lo[9], codepoint_string_hi[9];

  SCM_VALIDATE_SMOB (1, charset, charset);
  cs = SCM_CHARSET_DATA (charset);

  e1 = scm_cons (scm_from_locale_symbol ("char-set"),
                 charset);
  e2 = scm_cons (scm_from_locale_symbol ("n"),
                 scm_from_size_t (cs->len));

  for (i = 0; i < cs->len; i++)
    {
      if (cs->ranges[i].lo > 0xFFFF)
        sprintf (codepoint_string_lo, "U+%06x", cs->ranges[i].lo);
      else
        sprintf (codepoint_string_lo, "U+%04x", cs->ranges[i].lo);
      if (cs->ranges[i].hi > 0xFFFF)
        sprintf (codepoint_string_hi, "U+%06x", cs->ranges[i].hi);
      else
        sprintf (codepoint_string_hi, "U+%04x", cs->ranges[i].hi);

      elt = scm_list_4 (SCM_MAKE_CHAR (cs->ranges[i].lo),
                            SCM_MAKE_CHAR (cs->ranges[i].hi),
                            scm_from_locale_string (codepoint_string_lo),
                            scm_from_locale_string (codepoint_string_hi));
      ranges = scm_append (scm_list_2 (ranges,
                                       scm_list_1 (elt)));
    }
  e3 = scm_cons (scm_from_locale_symbol ("ranges"),
                 ranges);

  return scm_list_3 (e1, e2, e3);
}
#undef FUNC_NAME

void
scm_init_srfi_14 (void)
{
  scm_tc16_charset = scm_make_smob_type ("character-set", 0);
  scm_set_smob_print (scm_tc16_charset, charset_print);

  scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0);
  scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print);

  scm_char_set_upper_case =
    define_charset ("char-set:upper-case", &cs_upper_case);
  scm_char_set_lower_case =
    define_charset ("char-set:lower-case", &cs_lower_case);
  scm_char_set_title_case =
    define_charset ("char-set:title-case", &cs_title_case);
  scm_char_set_letter = define_charset ("char-set:letter", &cs_letter);
  scm_char_set_digit = define_charset ("char-set:digit", &cs_digit);
  scm_char_set_letter_and_digit =
    define_charset ("char-set:letter+digit", &cs_letter_plus_digit);
  scm_char_set_graphic = define_charset ("char-set:graphic", &cs_graphic);
  scm_char_set_printing = define_charset ("char-set:printing", &cs_printing);
  scm_char_set_whitespace =
    define_charset ("char-set:whitespace", &cs_whitespace);
  scm_char_set_iso_control =
    define_charset ("char-set:iso-control", &cs_iso_control);
  scm_char_set_punctuation =
    define_charset ("char-set:punctuation", &cs_punctuation);
  scm_char_set_symbol = define_charset ("char-set:symbol", &cs_symbol);
  scm_char_set_hex_digit =
    define_charset ("char-set:hex-digit", &cs_hex_digit);
  scm_char_set_blank = define_charset ("char-set:blank", &cs_blank);
  scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii);
  scm_char_set_empty = define_charset ("char-set:empty", &cs_empty);
  scm_char_set_designated = define_charset ("char-set:designated", &cs_designated);
  scm_char_set_full = define_charset ("char-set:full", &cs_full);

#include "libguile/srfi-14.x"
}

/* End of srfi-14.c.  */


code:
#ifndef SCM_SRFI_14_H
#define SCM_SRFI_14_H

/* srfi-14.c --- SRFI-14 procedures for Guile
 *
 * 	Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

typedef struct
{
  scm_t_wchar lo;
  scm_t_wchar hi;
} scm_t_char_range;

typedef struct
{
  size_t len;
  scm_t_char_range *ranges;
} scm_t_char_set;

typedef struct
{
  size_t range;
  scm_t_wchar n;
} scm_t_char_set_cursor;

#define SCM_CHARSET_GET(cs,idx)                                 \
  scm_i_charset_get((scm_t_char_set *)SCM_SMOB_DATA(cs),idx)

#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))

/* Smob type code for character sets.  */
SCM_API int scm_tc16_charset;
SCM_INTERNAL int scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n);
SCM_INTERNAL void scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n);
SCM_INTERNAL void scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n);

SCM_API SCM scm_char_set_p (SCM obj);
SCM_API SCM scm_char_set_eq (SCM char_sets);
SCM_API SCM scm_char_set_leq (SCM char_sets);
SCM_API SCM scm_char_set_hash (SCM cs, SCM bound);
SCM_API SCM scm_char_set_cursor (SCM cs);
SCM_API SCM scm_char_set_ref (SCM cs, SCM cursor);
SCM_API SCM scm_char_set_cursor_next (SCM cs, SCM cursor);
SCM_API SCM scm_end_of_char_set_p (SCM cursor);
SCM_API SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs);
SCM_API SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs);
SCM_API SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs);
SCM_API SCM scm_char_set_for_each (SCM proc, SCM cs);
SCM_API SCM scm_char_set_map (SCM proc, SCM cs);
SCM_API SCM scm_char_set_copy (SCM cs);
SCM_API SCM scm_char_set (SCM rest);
SCM_API SCM scm_list_to_char_set (SCM list, SCM base_cs);
SCM_API SCM scm_list_to_char_set_x (SCM list, SCM base_cs);
SCM_API SCM scm_string_to_char_set (SCM str, SCM base_cs);
SCM_API SCM scm_string_to_char_set_x (SCM str, SCM base_cs);
SCM_API SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs);
SCM_API SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs);
SCM_API SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs);
SCM_API SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs);
SCM_API SCM scm_to_char_set (SCM x);
SCM_API SCM scm_char_set_size (SCM cs);
SCM_API SCM scm_char_set_count (SCM pred, SCM cs);
SCM_API SCM scm_char_set_to_list (SCM cs);
SCM_API SCM scm_char_set_to_string (SCM cs);
SCM_API SCM scm_char_set_contains_p (SCM cs, SCM ch);
SCM_API SCM scm_char_set_every (SCM pred, SCM cs);
SCM_API SCM scm_char_set_any (SCM pred, SCM cs);
SCM_API SCM scm_char_set_adjoin (SCM cs, SCM rest);
SCM_API SCM scm_char_set_delete (SCM cs, SCM rest);
SCM_API SCM scm_char_set_adjoin_x (SCM cs, SCM rest);
SCM_API SCM scm_char_set_delete_x (SCM cs, SCM rest);
SCM_API SCM scm_char_set_complement (SCM cs);
SCM_API SCM scm_char_set_union (SCM rest);
SCM_API SCM scm_char_set_intersection (SCM rest);
SCM_API SCM scm_char_set_difference (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_xor (SCM rest);
SCM_API SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_complement_x (SCM cs);
SCM_API SCM scm_char_set_union_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest);
SCM_API SCM scm_sys_char_set_dump (SCM charset);

SCM_API SCM scm_char_set_lower_case;
SCM_API SCM scm_char_set_upper_case;
SCM_API SCM scm_char_set_title_case;
SCM_API SCM scm_char_set_letter;
SCM_API SCM scm_char_set_digit;
SCM_API SCM scm_char_set_letter_and_digit;
SCM_API SCM scm_char_set_graphic;
SCM_API SCM scm_char_set_printing;
SCM_API SCM scm_char_set_whitespace;
SCM_API SCM scm_char_set_iso_control;
SCM_API SCM scm_char_set_punctuation;
SCM_API SCM scm_char_set_symbol;
SCM_API SCM scm_char_set_hex_digit;
SCM_API SCM scm_char_set_blank;
SCM_API SCM scm_char_set_ascii;
SCM_API SCM scm_char_set_empty;
SCM_API SCM scm_char_set_full;

SCM_INTERNAL void scm_init_srfi_14 (void);

#endif /* SCM_SRFI_14_H */

license: mit


code:
/* srfi-4.c --- Uniform numeric vector datatypes.
 *
 * 	Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

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

#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
#include "libguile/bytevectors.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"

#define DEFINE_SCHEME_PROXY100(cname, modname, scmname)                   \
  SCM cname (SCM arg1)                                                  \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_call_1 (SCM_VARIABLE_REF (var), arg1);                   \
  }

#define DEFINE_SCHEME_PROXY001(cname, modname, scmname)                 \
  SCM cname (SCM args)                                                  \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_apply_0 (SCM_VARIABLE_REF (var), args);                  \
  }

#define DEFINE_SCHEME_PROXY110(cname, modname, scmname)                   \
  SCM cname (SCM arg1, SCM opt1)                                        \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    if (SCM_UNBNDP (opt1))                                              \
      return scm_call_1 (SCM_VARIABLE_REF (var), arg1);                 \
    else                                                                \
      return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1);           \
  }

#define DEFINE_SCHEME_PROXY200(cname, modname, scmname)                   \
  SCM cname (SCM arg1, SCM arg2)                                        \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2);             \
  }

#define DEFINE_SCHEME_PROXY300(cname, modname, scmname)                   \
  SCM cname (SCM arg1, SCM arg2, SCM arg3)                              \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3);       \
  }

#define DEFPROXY100(cname, scmname)               \
  DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
#define DEFPROXY110(cname, scmname)               \
  DEFINE_SCHEME_PROXY110 (cname, MOD, scmname)
#define DEFPROXY001(cname, scmname)               \
  DEFINE_SCHEME_PROXY001 (cname, MOD, scmname)
#define DEFPROXY200(cname, scmname)               \
  DEFINE_SCHEME_PROXY200 (cname, MOD, scmname)
#define DEFPROXY300(cname, scmname)               \
  DEFINE_SCHEME_PROXY300 (cname, MOD, scmname)

#define DEFVECT(sym, str, func)\

#define DEFINE_SRFI_4_PROXIES(tag)                                      \
  DEFPROXY100 (scm_##tag##vector_p, #tag "vector?");                    \
  DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector");          \
  DEFPROXY001 (scm_##tag##vector, #tag "vector");                       \
  DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length");         \
  DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref");               \
  DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!");            \
  DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector");       \
  DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list");         \

#define ETYPE(TAG) \
  SCM_ARRAY_ELEMENT_TYPE_##TAG

#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width)                   \
  SCM scm_take_##tag##vector (ctype *data, size_t n)                    \
  {                                                                     \
    return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG));   \
  }                                                                     \
  const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
  {                                                                     \
    if (h->element_type != ETYPE (TAG))                                 \
      scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector");        \
    return ((const ctype*) h->elements) + h->base*width;                \
  }                                                                     \
  ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
  {                                                                     \
    if (h->element_type != ETYPE (TAG))                                 \
      scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector");        \
    return ((ctype*) h->writable_elements) + h->base*width;             \
  }                                                                     \
  const ctype *scm_##tag##vector_elements (SCM uvec,                    \
                                           scm_t_array_handle *h,       \
                                           size_t *lenp, ssize_t *incp) \
  {                                                                     \
    return scm_##tag##vector_writable_elements (uvec, h, lenp, incp);   \
  }                                                                     \
  ctype *scm_##tag##vector_writable_elements (SCM uvec,                 \
                                              scm_t_array_handle *h,    \
                                              size_t *lenp, ssize_t *incp) \
  {                                                                     \
    scm_uniform_vector_elements (uvec, h, lenp, incp);                  \
    if (h->element_type == ETYPE (TAG))                                 \
      return ((ctype*)h->writable_elements) + h->base*width;            \
    /* otherwise... */                                                  \
    else                                                                \
      {                                                                 \
        size_t sfrom, sto, lfrom, lto;                                  \
        if (h->dims != &h->dim0)                                        \
          {                                                             \
            h->dim0 = h->dims[0];                                       \
            h->dims = &h->dim0;                                         \
          }                                                             \
        sfrom = scm_i_array_element_type_sizes [h->element_type];       \
        sto = scm_i_array_element_type_sizes [ETYPE (TAG)];             \
        lfrom = h->dim0.ubnd - h->dim0.lbnd + 1;                        \
        lto = lfrom * sfrom / sto;                                      \
        if (lto * sto != lfrom * sfrom)                                 \
          {                                                             \
            scm_array_handle_release (h);                               \
            scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
          }                                                             \
        h->dim0.ubnd = h->dim0.lbnd + lto;                              \
        h->base = h->base * sto / sfrom;                                \
        h->element_type = ETYPE (TAG);                                  \
        return ((ctype*)h->writable_elements) + h->base*width;          \
      }                                                                 \
  }

#define MOD "srfi srfi-4"

DEFINE_SRFI_4_PROXIES (u8);
DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1);

DEFINE_SRFI_4_PROXIES (s8);
DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1);

DEFINE_SRFI_4_PROXIES (u16);
DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1);

DEFINE_SRFI_4_PROXIES (s16);
DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1);

DEFINE_SRFI_4_PROXIES (u32);
DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1);

DEFINE_SRFI_4_PROXIES (s32);
DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);

DEFINE_SRFI_4_PROXIES (u64);
DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);

DEFINE_SRFI_4_PROXIES (s64);
DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);

DEFINE_SRFI_4_PROXIES (f32);
DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);

DEFINE_SRFI_4_PROXIES (f64);
DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1);

#undef MOD
#define MOD "srfi srfi-4 gnu"

DEFINE_SRFI_4_PROXIES (c32);
DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2);

DEFINE_SRFI_4_PROXIES (c64);
DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2);

#define DEFINE_SRFI_4_GNU_PROXIES(tag)                              \
  DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")

#undef MOD
#define MOD "srfi srfi-4 gnu"
DEFINE_SRFI_4_GNU_PROXIES (u8);
DEFINE_SRFI_4_GNU_PROXIES (s8);
DEFINE_SRFI_4_GNU_PROXIES (u16);
DEFINE_SRFI_4_GNU_PROXIES (s16);
DEFINE_SRFI_4_GNU_PROXIES (u32);
DEFINE_SRFI_4_GNU_PROXIES (s32);
DEFINE_SRFI_4_GNU_PROXIES (u64);
DEFINE_SRFI_4_GNU_PROXIES (s64);
DEFINE_SRFI_4_GNU_PROXIES (f32);
DEFINE_SRFI_4_GNU_PROXIES (f64);
DEFINE_SRFI_4_GNU_PROXIES (c32);
DEFINE_SRFI_4_GNU_PROXIES (c64);

SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
            (SCM type, SCM len, SCM fill),
            "Make a srfi-4 vector")
#define FUNC_NAME s_scm_make_srfi_4_vector
{
  int i;
  for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
    if (scm_is_eq (type, scm_i_array_element_types[i]))
      break;
  if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
  switch (i)
    {
    case SCM_ARRAY_ELEMENT_TYPE_U8:
    case SCM_ARRAY_ELEMENT_TYPE_S8:
    case SCM_ARRAY_ELEMENT_TYPE_U16:
    case SCM_ARRAY_ELEMENT_TYPE_S16:
    case SCM_ARRAY_ELEMENT_TYPE_U32:
    case SCM_ARRAY_ELEMENT_TYPE_S32:
    case SCM_ARRAY_ELEMENT_TYPE_U64:
    case SCM_ARRAY_ELEMENT_TYPE_S64:
    case SCM_ARRAY_ELEMENT_TYPE_F32:
    case SCM_ARRAY_ELEMENT_TYPE_F64:
    case SCM_ARRAY_ELEMENT_TYPE_C32:
    case SCM_ARRAY_ELEMENT_TYPE_C64:
      {
        SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);

        if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0))
          ; /* pass */
        else if (scm_is_true (scm_zero_p (fill)))
          memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
                  SCM_BYTEVECTOR_LENGTH (ret));
        else
          {
            scm_t_array_handle h;
            size_t len;
            ssize_t pos, inc;

            scm_uniform_vector_writable_elements (ret, &h, &len, &inc);

            for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
              scm_array_handle_set (&h, pos, fill);

	    /* Initialize the last element.  */
	    scm_array_handle_set (&h, pos, fill);

            scm_array_handle_release (&h);
          }
        return ret;
      }
    default:
      scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type");
      return SCM_BOOL_F; /* not reached */
    }
}
#undef FUNC_NAME

void
scm_init_srfi_4 (void)
{
#define REGISTER(tag, TAG)                                       \
  scm_i_register_vector_constructor                              \
    (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG],    \
     scm_make_##tag##vector)

  REGISTER (u8, U8);
  REGISTER (s8, S8);
  REGISTER (u16, U16);
  REGISTER (s16, S16);
  REGISTER (u32, U32);
  REGISTER (s32, S32);
  REGISTER (u64, U64);
  REGISTER (s64, S64);
  REGISTER (f32, F32);
  REGISTER (f64, F64);
  REGISTER (c32, C32);
  REGISTER (c64, C64);

#include "libguile/srfi-4.x"
}

/* End of srfi-4.c.  */


code:
#ifndef SCM_SRFI_4_H
#define SCM_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
 *
 * 	Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_make_srfi_4_vector (SCM type, SCM len, SCM fill);

/* Specific procedures.
 */

SCM_API SCM scm_u8vector_p (SCM obj);
SCM_API SCM scm_make_u8vector (SCM n, SCM fill);
SCM_API SCM scm_take_u8vector (scm_t_uint8 *data, size_t n);
SCM_API SCM scm_u8vector (SCM l);
SCM_API SCM scm_u8vector_length (SCM uvec);
SCM_API SCM scm_u8vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u8vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u8vector (SCM l);
SCM_API SCM scm_any_to_u8vector (SCM obj);
SCM_API const scm_t_uint8 *scm_array_handle_u8_elements (scm_t_array_handle *h);
SCM_API scm_t_uint8 *scm_array_handle_u8_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint8 *scm_u8vector_elements (SCM uvec,
						  scm_t_array_handle *h,
						  size_t *lenp, ssize_t *incp);
SCM_API scm_t_uint8 *scm_u8vector_writable_elements (SCM uvec,
						     scm_t_array_handle *h,
						     size_t *lenp,
						     ssize_t *incp);

SCM_API SCM scm_s8vector_p (SCM obj);
SCM_API SCM scm_make_s8vector (SCM n, SCM fill);
SCM_API SCM scm_take_s8vector (scm_t_int8 *data, size_t n);
SCM_API SCM scm_s8vector (SCM l);
SCM_API SCM scm_s8vector_length (SCM uvec);
SCM_API SCM scm_s8vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s8vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s8vector (SCM l);
SCM_API SCM scm_any_to_s8vector (SCM obj);
SCM_API const scm_t_int8 *scm_array_handle_s8_elements (scm_t_array_handle *h);
SCM_API scm_t_int8 *scm_array_handle_s8_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int8 *scm_s8vector_elements (SCM uvec,
						 scm_t_array_handle *h,
						 size_t *lenp, ssize_t *incp);
SCM_API scm_t_int8 *scm_s8vector_writable_elements (SCM uvec,
						    scm_t_array_handle *h,
						    size_t *lenp,
						    ssize_t *incp);

SCM_API SCM scm_u16vector_p (SCM obj);
SCM_API SCM scm_make_u16vector (SCM n, SCM fill);
SCM_API SCM scm_take_u16vector (scm_t_uint16 *data, size_t n);
SCM_API SCM scm_u16vector (SCM l);
SCM_API SCM scm_u16vector_length (SCM uvec);
SCM_API SCM scm_u16vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u16vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u16vector (SCM l);
SCM_API SCM scm_any_to_u16vector (SCM obj);
SCM_API const scm_t_uint16 *scm_array_handle_u16_elements (scm_t_array_handle *h);
SCM_API scm_t_uint16 *scm_array_handle_u16_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint16 *scm_u16vector_elements (SCM uvec,
						    scm_t_array_handle *h,
						    size_t *lenp,
						    ssize_t *incp);
SCM_API scm_t_uint16 *scm_u16vector_writable_elements (SCM uvec,
						       scm_t_array_handle *h,
						       size_t *lenp,
						       ssize_t *incp);

SCM_API SCM scm_s16vector_p (SCM obj);
SCM_API SCM scm_make_s16vector (SCM n, SCM fill);
SCM_API SCM scm_take_s16vector (scm_t_int16 *data, size_t n);
SCM_API SCM scm_s16vector (SCM l);
SCM_API SCM scm_s16vector_length (SCM uvec);
SCM_API SCM scm_s16vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s16vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s16vector (SCM l);
SCM_API SCM scm_any_to_s16vector (SCM obj);
SCM_API const scm_t_int16 *scm_array_handle_s16_elements (scm_t_array_handle *h);
SCM_API scm_t_int16 *scm_array_handle_s16_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int16 *scm_s16vector_elements (SCM uvec,
						   scm_t_array_handle *h,
						   size_t *lenp, ssize_t *incp);
SCM_API scm_t_int16 *scm_s16vector_writable_elements (SCM uvec,
						      scm_t_array_handle *h,
						      size_t *lenp,
						      ssize_t *incp);

SCM_API SCM scm_u32vector_p (SCM obj);
SCM_API SCM scm_make_u32vector (SCM n, SCM fill);
SCM_API SCM scm_take_u32vector (scm_t_uint32 *data, size_t n);
SCM_API SCM scm_u32vector (SCM l);
SCM_API SCM scm_u32vector_length (SCM uvec);
SCM_API SCM scm_u32vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u32vector (SCM l);
SCM_API SCM scm_any_to_u32vector (SCM obj);
SCM_API const scm_t_uint32 *scm_array_handle_u32_elements (scm_t_array_handle *h);
SCM_API scm_t_uint32 *scm_array_handle_u32_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint32 *scm_u32vector_elements (SCM uvec,
						    scm_t_array_handle *h,
						    size_t *lenp,
						    ssize_t *incp);
SCM_API scm_t_uint32 *scm_u32vector_writable_elements (SCM uvec,
						       scm_t_array_handle *h,
						       size_t *lenp,
						       ssize_t *incp);

SCM_API SCM scm_s32vector_p (SCM obj);
SCM_API SCM scm_make_s32vector (SCM n, SCM fill);
SCM_API SCM scm_take_s32vector (scm_t_int32 *data, size_t n);
SCM_API SCM scm_s32vector (SCM l);
SCM_API SCM scm_s32vector_length (SCM uvec);
SCM_API SCM scm_s32vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s32vector (SCM l);
SCM_API SCM scm_any_to_s32vector (SCM obj);
SCM_API const scm_t_int32 *scm_array_handle_s32_elements (scm_t_array_handle *h);
SCM_API scm_t_int32 *scm_array_handle_s32_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int32 *scm_s32vector_elements (SCM uvec,
						   scm_t_array_handle *h,
						   size_t *lenp, ssize_t *incp);
SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec,
						      scm_t_array_handle *h,
						      size_t *lenp,
						      ssize_t *incp);

SCM_API SCM scm_u64vector_p (SCM obj);
SCM_API SCM scm_make_u64vector (SCM n, SCM fill);
SCM_API SCM scm_u64vector (SCM l);
SCM_API SCM scm_u64vector_length (SCM uvec);
SCM_API SCM scm_u64vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u64vector (SCM l);
SCM_API SCM scm_any_to_u64vector (SCM obj);

SCM_API SCM scm_take_u64vector (scm_t_uint64 *data, size_t n);
SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h);
SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec,
						    scm_t_array_handle *h,
						    size_t *lenp,
						    ssize_t *incp);
SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec,
						       scm_t_array_handle *h,
						       size_t *lenp,
						       ssize_t *incp);

SCM_API SCM scm_s64vector_p (SCM obj);
SCM_API SCM scm_make_s64vector (SCM n, SCM fill);
SCM_API SCM scm_s64vector (SCM l);
SCM_API SCM scm_s64vector_length (SCM uvec);
SCM_API SCM scm_s64vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s64vector (SCM l);
SCM_API SCM scm_any_to_s64vector (SCM obj);

SCM_API SCM scm_take_s64vector (scm_t_int64 *data, size_t n);
SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h);
SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec,
						   scm_t_array_handle *h,
						   size_t *lenp, ssize_t *incp);
SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec,
						      scm_t_array_handle *h,
						      size_t *lenp,
						      ssize_t *incp);

SCM_API SCM scm_f32vector_p (SCM obj);
SCM_API SCM scm_make_f32vector (SCM n, SCM fill);
SCM_API SCM scm_take_f32vector (float *data, size_t n);
SCM_API SCM scm_f32vector (SCM l);
SCM_API SCM scm_f32vector_length (SCM uvec);
SCM_API SCM scm_f32vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_f32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_f32vector (SCM l);
SCM_API SCM scm_any_to_f32vector (SCM obj);
SCM_API const float *scm_array_handle_f32_elements (scm_t_array_handle *h);
SCM_API float *scm_array_handle_f32_writable_elements (scm_t_array_handle *h);
SCM_API const float *scm_f32vector_elements (SCM uvec,
					    scm_t_array_handle *h,
					    size_t *lenp, ssize_t *incp);
SCM_API float *scm_f32vector_writable_elements (SCM uvec,
						scm_t_array_handle *h,
						size_t *lenp,
						ssize_t *incp);

SCM_API SCM scm_f64vector_p (SCM obj);
SCM_API SCM scm_make_f64vector (SCM n, SCM fill);
SCM_API SCM scm_take_f64vector (double *data, size_t n);
SCM_API SCM scm_f64vector (SCM l);
SCM_API SCM scm_f64vector_length (SCM uvec);
SCM_API SCM scm_f64vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_f64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_f64vector (SCM l);
SCM_API SCM scm_any_to_f64vector (SCM obj);
SCM_API const double *scm_array_handle_f64_elements (scm_t_array_handle *h);
SCM_API double *scm_array_handle_f64_writable_elements (scm_t_array_handle *h);
SCM_API const double *scm_f64vector_elements (SCM uvec,
					      scm_t_array_handle *h,
					      size_t *lenp, ssize_t *incp);
SCM_API double *scm_f64vector_writable_elements (SCM uvec,
						 scm_t_array_handle *h,
						 size_t *lenp,
						 ssize_t *incp);

SCM_API SCM scm_c32vector_p (SCM obj);
SCM_API SCM scm_make_c32vector (SCM n, SCM fill);
SCM_API SCM scm_take_c32vector (float *data, size_t n);
SCM_API SCM scm_c32vector (SCM l);
SCM_API SCM scm_c32vector_length (SCM uvec);
SCM_API SCM scm_c32vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_c32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_c32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_c32vector (SCM l);
SCM_API SCM scm_any_to_c32vector (SCM obj);
SCM_API const float *scm_array_handle_c32_elements (scm_t_array_handle *h);
SCM_API float *scm_array_handle_c32_writable_elements (scm_t_array_handle *h);
SCM_API const float *scm_c32vector_elements (SCM uvec,
					     scm_t_array_handle *h,
					     size_t *lenp, ssize_t *incp);
SCM_API float *scm_c32vector_writable_elements (SCM uvec,
						scm_t_array_handle *h,
						size_t *lenp,
						ssize_t *incp);

SCM_API SCM scm_c64vector_p (SCM obj);
SCM_API SCM scm_make_c64vector (SCM n, SCM fill);
SCM_API SCM scm_take_c64vector (double *data, size_t n);
SCM_API SCM scm_c64vector (SCM l);
SCM_API SCM scm_c64vector_length (SCM uvec);
SCM_API SCM scm_c64vector_ref (SCM uvec, SCM index);
SCM_API SCM scm_c64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_c64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_c64vector (SCM l);
SCM_API SCM scm_any_to_c64vector (SCM obj);
SCM_API const double *scm_array_handle_c64_elements (scm_t_array_handle *h);
SCM_API double *scm_array_handle_c64_writable_elements (scm_t_array_handle *h);
SCM_API const double *scm_c64vector_elements (SCM uvec,
					      scm_t_array_handle *h,
					      size_t *lenp, ssize_t *incp);
SCM_API double *scm_c64vector_writable_elements (SCM uvec,
						 scm_t_array_handle *h,
						 size_t *lenp,
						 ssize_t *incp);

SCM_INTERNAL SCM scm_i_generalized_vector_type (SCM vec);
SCM_INTERNAL const char *scm_i_uniform_vector_tag (SCM uvec);
SCM_INTERNAL scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec);
SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec);

#if SCM_ENABLE_DEPRECATED

/* Deprecated because we want people to use the scm_t_array_handle
   interface.
*/

SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj);

#endif

SCM_INTERNAL void scm_init_srfi_4 (void);

#endif /* SCM_SRFI_4_H */


code:
/*	Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

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

#include "libguile/_scm.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/threads.h"

#include "libguile/stackchk.h"

/* {Stack Checking}
 */

#ifdef STACK_CHECKING
int scm_stack_checking_enabled_p;

SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");

void
scm_report_stack_overflow ()
{
  scm_stack_checking_enabled_p = 0;
  scm_error (scm_stack_overflow_key,
	     NULL,
	     "Stack overflow",
	     SCM_BOOL_F,
	     SCM_BOOL_F);
}

#endif

long
scm_stack_size (SCM_STACKITEM *start)
{
  SCM_STACKITEM stack;
#if SCM_STACK_GROWS_UP
  return &stack - start;
#else
  return start - &stack;
#endif /* SCM_STACK_GROWS_UP */
}

void
scm_stack_report ()
{
  SCM port = scm_current_error_port ();
  SCM_STACKITEM stack;
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;

  scm_uintprint ((scm_stack_size (thread->continuation_base)
		  * sizeof (SCM_STACKITEM)),
		 16, port);
  scm_puts (" of stack: 0x", port);
  scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
  scm_puts (" - 0x", port);
  scm_uintprint ((scm_t_bits) &stack, 16, port);
  scm_puts ("\n", port);
}

SCM_DEFINE (scm_sys_get_stack_size, "%get-stack-size", 0, 0, 0,
	    (),
	    "Return the current thread's C stack size (in Scheme objects).")
#define FUNC_NAME s_scm_sys_get_stack_size
{
  return scm_from_long (scm_stack_size (SCM_I_CURRENT_THREAD->base));
}
#undef FUNC_NAME

void
scm_init_stackchk ()
{
#include "libguile/stackchk.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H

/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

#include "libguile/continuations.h"
#include "libguile/debug.h"

/* With debug options we have the possibility to disable stack checking.
 */
#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT

#if defined BUILDING_LIBGUILE && defined STACK_CHECKING
# if SCM_STACK_GROWS_UP
#  define SCM_STACK_OVERFLOW_P(s)\
   ((SCM_STACK_PTR (s) - SCM_I_CURRENT_THREAD->base) > SCM_STACK_LIMIT)
# else
#  define SCM_STACK_OVERFLOW_P(s)\
   ((SCM_I_CURRENT_THREAD->base - SCM_STACK_PTR (s)) > SCM_STACK_LIMIT)
# endif
# define SCM_CHECK_STACK\
    {\
       SCM_STACKITEM stack;\
       if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\
	 scm_report_stack_overflow ();\
    }
#else
# define SCM_CHECK_STACK /**/
#endif

SCM_API int scm_stack_checking_enabled_p;

SCM_API void scm_report_stack_overflow (void);
SCM_API long scm_stack_size (SCM_STACKITEM *start);
SCM_API void scm_stack_report (void);
SCM_API SCM scm_sys_get_stack_size (void);
SCM_INTERNAL void scm_init_stackchk (void);

#endif  /* SCM_STACKCHK_H */

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