code:
#ifndef SCM_SRFI_13_H
#define SCM_SRFI_13_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_string_null_p (SCM s);
SCM_API SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_tabulate (SCM proc, SCM len);
SCM_API SCM scm_string_to_list (SCM str);
SCM_API SCM scm_substring_to_list (SCM str, SCM start, SCM end);
SCM_API SCM scm_reverse_list_to_string (SCM chrs);
SCM_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar);
SCM_API SCM scm_string_copy (SCM str);
SCM_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end);
SCM_API SCM scm_substring_move_x (SCM str1, SCM start1, SCM end1,
				  SCM str2, SCM start2);
SCM_API SCM scm_string_take (SCM s, SCM n);
SCM_API SCM scm_string_drop (SCM s, SCM n);
SCM_API SCM scm_string_take_right (SCM s, SCM n);
SCM_API SCM scm_string_drop_right (SCM s, SCM n);
SCM_API SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end);
SCM_API SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end);
SCM_API SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_substring_fill_x (SCM str, SCM chr, SCM start, SCM end);
SCM_API SCM scm_string_fill_x (SCM str, SCM chr);
SCM_API SCM scm_string_compare (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_compare_ci (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_substring_hash (SCM s, SCM bound, SCM start, SCM end);
SCM_API SCM scm_substring_hash_ci (SCM s, SCM bound, SCM start, SCM end);
SCM_API SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_index (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_rindex (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_substring_upcase_x (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_upcase (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_upcase_x (SCM str);
SCM_API SCM scm_string_upcase (SCM str);
SCM_API SCM scm_substring_downcase_x (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_downcase (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_downcase_x (SCM str);
SCM_API SCM scm_string_downcase (SCM str);
SCM_API SCM scm_string_titlecase_x (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_titlecase (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_capitalize_x (SCM str);
SCM_API SCM scm_string_capitalize (SCM str);
SCM_API SCM scm_string_reverse (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_reverse_x (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_append_shared (SCM ls);
SCM_API SCM scm_string_concatenate (SCM ls);
SCM_API SCM scm_string_concatenate_shared (SCM ls);
SCM_API SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end);
SCM_API SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end);
SCM_API SCM scm_string_map (SCM proc, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_map_x (SCM proc, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final);
SCM_API SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final);
SCM_API SCM scm_string_for_each (SCM proc, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_for_each_index (SCM proc, SCM s, SCM start, SCM end);
SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end);
SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end);
SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end);
SCM_API SCM scm_string_split (SCM s, SCM chr);
SCM_API SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end);
SCM_API SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end);

SCM_API void scm_init_srfi_13 (void);
SCM_API void scm_init_srfi_13_14 (void);

#endif /* SCM_SRFI_13_H */

license: unknown


code:
/* 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <string.h>
#include <ctype.h>

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

#define SCM_CHARSET_SET(cs, idx)				\
  (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |=	\
    (1L << ((idx) % SCM_BITS_PER_LONG)))

#define SCM_CHARSET_UNSET(cs, idx)				\
  (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] &=	\
    (~(1L << ((idx) % SCM_BITS_PER_LONG))))

#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8)
#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG)

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

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

  scm_puts ("#<charset {", port);
  for (i = 0; i < SCM_CHARSET_SIZE; i++)
    if (SCM_CHARSET_GET (charset, i))
      {
	if (first)
	  first = 0;
	else
	  scm_puts (" ", port);
	scm_write (SCM_MAKE_CHAR (i), port);
      }
  scm_puts ("}>", port);
  return 1;
}

/* Smob free hook for character sets. */
static size_t
charset_free (SCM charset)
{
  return scm_smob_free (charset);
}

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

  p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set");
  memset (p, 0, BYTES_PER_CHARSET);
  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;
  long *cs1_data = NULL;

  SCM_VALIDATE_REST_ARGUMENT (char_sets);

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

      SCM_VALIDATE_SMOB (argnum, csi, charset);
      argnum++;
      csi_data = (long *) SCM_SMOB_DATA (csi);
      if (cs1_data == NULL)
	cs1_data = csi_data;
      else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0)
	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;
  long *prev_data = NULL;

  SCM_VALIDATE_REST_ARGUMENT (char_sets);

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

      SCM_VALIDATE_SMOB (argnum, csi, charset);
      argnum++;
      csi_data = (long *) SCM_SMOB_DATA (csi);
      if (prev_data)
	{
	  int k;

	  for (k = 0; k < LONGS_PER_CHARSET; k++)
	    {
	      if ((prev_data[k] & csi_data[k]) != prev_data[k])
		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;
  long * p;
  unsigned long val = 0;
  int k;

  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 = (long *) SCM_SMOB_DATA (cs);
  for (k = 0; k < LONGS_PER_CHARSET; k++)
    {
      if (p[k] != 0)
        val = p[k] + (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
{
  int idx;

  SCM_VALIDATE_SMOB (1, cs, charset);
  for (idx = 0; idx < SCM_CHARSET_SIZE; idx++)
    {
      if (SCM_CHARSET_GET (cs, idx))
	break;
    }
  return SCM_I_MAKINUM (idx);
}
#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
{
  size_t ccursor = scm_to_size_t (cursor);
  SCM_VALIDATE_SMOB (1, cs, charset);

  if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
    SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
  return SCM_MAKE_CHAR (ccursor);
}
#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
{
  size_t ccursor = scm_to_size_t (cursor);
  SCM_VALIDATE_SMOB (1, cs, charset);

  if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
    SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
  for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++)
    {
      if (SCM_CHARSET_GET (cs, ccursor))
	break;
    }
  return SCM_I_MAKINUM (ccursor);
}
#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
{
  size_t ccursor = scm_to_size_t (cursor);
  return scm_from_bool (ccursor >= SCM_CHARSET_SIZE);
}
#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
{
  int k;

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

  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      {
	knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), 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
{
  int k;

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

  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      scm_call_1 (proc, SCM_MAKE_CHAR (k));
  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_VALIDATE_PROC (1, proc);
  SCM_VALIDATE_SMOB (2, cs, charset);

  result = make_char_set (FUNC_NAME);
  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      {
	SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k));
	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;
  long * p1, * p2;
  int k;

  SCM_VALIDATE_SMOB (1, cs, charset);
  ret = make_char_set (FUNC_NAME);
  p1 = (long *) SCM_SMOB_DATA (cs);
  p2 = (long *) SCM_SMOB_DATA (ret);
  for (k = 0; k < LONGS_PER_CHARSET; k++)
    p2[k] = p1[k];
  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;
  long * p;
  int argnum = 1;

  SCM_VALIDATE_REST_ARGUMENT (rest);
  cs = make_char_set (FUNC_NAME);
  p = (long *) SCM_SMOB_DATA (cs);
  while (!scm_is_null (rest))
    {
      int c;

      SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
      argnum++;
      rest = SCM_CDR (rest);
      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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;
  long * p;

  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);
    }
  p = (long *) SCM_SMOB_DATA (cs);
  while (!scm_is_null (list))
    {
      SCM chr = SCM_CAR (list);
      int c;

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

      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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
{
  long * p;

  SCM_VALIDATE_LIST (1, list);
  SCM_VALIDATE_SMOB (2, base_cs, charset);
  p = (long *) SCM_SMOB_DATA (base_cs);
  while (!scm_is_null (list))
    {
      SCM chr = SCM_CAR (list);
      int c;

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

      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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;
  long * p;
  const char * s;
  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);
    }
  p = (long *) SCM_SMOB_DATA (cs);
  s = scm_i_string_chars (str);
  len = scm_i_string_length (str);
  while (k < len)
    {
      int c = s[k++];
      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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
{
  long * p;
  const char * s;
  size_t k = 0, len;

  SCM_VALIDATE_STRING (1, str);
  SCM_VALIDATE_SMOB (2, base_cs, charset);
  p = (long *) SCM_SMOB_DATA (base_cs);
  s = scm_i_string_chars (str);
  len = scm_i_string_length (str);
  while (k < len)
    {
      int c = s[k++];
      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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;
  long * 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 = (long *) SCM_SMOB_DATA (ret);
  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    {
      if (SCM_CHARSET_GET (cs, k))
	{
	  SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));

	  if (scm_is_true (res))
	    p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
	}
    }
  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;
  long * p;

  SCM_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);
  SCM_VALIDATE_SMOB (3, base_cs, charset);
  p = (long *) SCM_SMOB_DATA (base_cs);
  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    {
      if (SCM_CHARSET_GET (cs, k))
	{
	  SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));

	  if (scm_is_true (res))
	    p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
	}
    }
  return base_cs;
}
#undef FUNC_NAME

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 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 in @var{base_cs} are added to the result, if\n"
	    "given.")
#define FUNC_NAME s_scm_ucs_range_to_char_set
{
  SCM cs;
  size_t clower, cupper;
  long * p;

  clower = scm_to_size_t (lower);
  cupper = scm_to_size_t (upper);
  SCM_ASSERT_RANGE (2, upper, cupper >= clower);
  if (!SCM_UNBNDP (error))
    {
      if (scm_is_true (error))
	{
	  SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
	  SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
	}
    }
  if (clower > SCM_CHARSET_SIZE)
    clower = SCM_CHARSET_SIZE;
  if (cupper > SCM_CHARSET_SIZE)
    cupper = SCM_CHARSET_SIZE;
  if (SCM_UNBNDP (base_cs))
    cs = make_char_set (FUNC_NAME);
  else
    {
      SCM_VALIDATE_SMOB (4, base_cs, charset);
      cs = scm_char_set_copy (base_cs);
    }
  p = (long *) SCM_SMOB_DATA (cs);
  while (clower < cupper)
    {
      p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
      clower++;
    }
  return cs;
}
#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
{
  size_t clower, cupper;
  long * p;

  clower = scm_to_size_t (lower);
  cupper = scm_to_size_t (upper);
  SCM_ASSERT_RANGE (2, upper, cupper >= clower);
  if (scm_is_true (error))
    {
      SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
      SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
    }
  if (clower > SCM_CHARSET_SIZE)
    clower = SCM_CHARSET_SIZE;
  if (cupper > SCM_CHARSET_SIZE)
    cupper = SCM_CHARSET_SIZE;
  p = (long *) SCM_SMOB_DATA (base_cs);
  while (clower < cupper)
    {
      p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
      clower++;
    }
  return base_cs;
}
#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_VALIDATE_SMOB (1, cs, charset);
  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      count++;
  return SCM_I_MAKINUM (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_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);

  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      {
	SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
	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 result = SCM_EOL;

  SCM_VALIDATE_SMOB (1, cs, charset);
  for (k = SCM_CHARSET_SIZE; k > 0; k--)
    if (SCM_CHARSET_GET (cs, k - 1))
      result = scm_cons (SCM_MAKE_CHAR (k - 1), 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;
  SCM result;
  char * p;

  SCM_VALIDATE_SMOB (1, cs, charset);
  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      count++;
  result = scm_i_make_string (count, &p);
  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      p[idx++] = k;
  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 res = SCM_BOOL_T;

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

  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      {
	res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
	if (scm_is_false (res))
	  return res;
      }
  return res;
}
#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_VALIDATE_PROC (1, pred);
  SCM_VALIDATE_SMOB (2, cs, charset);

  for (k = 0; k < SCM_CHARSET_SIZE; k++)
    if (SCM_CHARSET_GET (cs, k))
      {
	SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
	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
{
  long * p;

  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);
  cs = scm_char_set_copy (cs);

  p = (long *) SCM_SMOB_DATA (cs);
  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      int c;

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

      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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
{
  long * p;

  SCM_VALIDATE_SMOB (1, cs, charset);
  SCM_VALIDATE_REST_ARGUMENT (rest);
  cs = scm_char_set_copy (cs);

  p = (long *) SCM_SMOB_DATA (cs);
  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      int c;

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

      p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
    }
  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
{
  long * p;

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

  p = (long *) SCM_SMOB_DATA (cs);
  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      int c;

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

      p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
    }
  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
{
  long * p;

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

  p = (long *) SCM_SMOB_DATA (cs);
  while (!scm_is_null (rest))
    {
      SCM chr = SCM_CAR (rest);
      int c;

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

      p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
    }
  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
{
  int k;
  SCM res;
  long * p, * q;

  SCM_VALIDATE_SMOB (1, cs, charset);

  res = make_char_set (FUNC_NAME);
  p = (long *) SCM_SMOB_DATA (res);
  q = (long *) SCM_SMOB_DATA (cs);
  for (k = 0; k < LONGS_PER_CHARSET; k++)
    p[k] = ~q[k];
  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;
  long * p;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  res = make_char_set (FUNC_NAME);
  p = (long *) SCM_SMOB_DATA (res);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
    }
  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
    {
      long *p;
      int argnum = 2;

      res = scm_char_set_copy (SCM_CAR (rest));
      p = (long *) SCM_SMOB_DATA (res);
      rest = SCM_CDR (rest);

      while (scm_is_pair (rest))
	{
	  int k;
	  SCM cs = SCM_CAR (rest);
	  long *cs_data;

	  SCM_VALIDATE_SMOB (argnum, cs, charset);
	  argnum++;
	  cs_data = (long *) SCM_SMOB_DATA (cs);
	  rest = SCM_CDR (rest);
	  for (k = 0; k < LONGS_PER_CHARSET; k++)
	    p[k] &= cs_data[k];
	}
    }

  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;
  long * p;

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

  res = scm_char_set_copy (cs1);
  p = (long *) SCM_SMOB_DATA (res);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
    }
  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;
      long * p;

      res = scm_char_set_copy (SCM_CAR (rest));
      p = (long *) SCM_SMOB_DATA (res);
      rest = SCM_CDR (rest);

      while (scm_is_pair (rest))
	{
	  SCM cs = SCM_CAR (rest);
	  long *cs_data;
	  int k;

	  SCM_VALIDATE_SMOB (argnum, cs, charset);
	  argnum++;
	  cs_data = (long *) SCM_SMOB_DATA (cs);
	  rest = SCM_CDR (rest);

	  for (k = 0; k < LONGS_PER_CHARSET; k++)
	    p[k] ^= cs_data[k];
	}
    }
  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;
  long * 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 = (long *) SCM_SMOB_DATA (res1);
  q = (long *) SCM_SMOB_DATA (res2);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      long *r;

      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      r = (long *) SCM_SMOB_DATA (cs);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	{
	  q[k] |= p[k] & r[k];
	  p[k] &= ~r[k];
	}
      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
{
  int k;
  long * p;

  SCM_VALIDATE_SMOB (1, cs, charset);
  p = (long *) SCM_SMOB_DATA (cs);
  for (k = 0; k < LONGS_PER_CHARSET; k++)
    p[k] = ~p[k];
  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
{
  int c = 2;
  long * p;

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

  p = (long *) SCM_SMOB_DATA (cs1);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
    }
  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
{
  int c = 2;
  long * p;

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

  p = (long *) SCM_SMOB_DATA (cs1);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
    }
  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
{
  int c = 2;
  long * p;

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

  p = (long *) SCM_SMOB_DATA (cs1);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
    }
  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
  */
  return scm_char_set_xor (scm_cons (cs1, rest));

#if 0
  /* this would give (char-set-xor! a a a) -> empty char set.  */
  int c = 2;
  long * p;

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

  p = (long *) SCM_SMOB_DATA (cs1);
  while (!scm_is_null (rest))
    {
      int k;
      SCM cs = SCM_CAR (rest);
      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      rest = SCM_CDR (rest);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
    }
  return cs1;
#endif
}
#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
{
  int c = 3;
  long * p, * q;
  int k;

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

  p = (long *) SCM_SMOB_DATA (cs1);
  q = (long *) SCM_SMOB_DATA (cs2);
  if (p == q)
    {
      /* (char-set-diff+intersection! a a ...): can't share storage,
	 but we know the answer without checking for further
	 arguments.  */
      return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1));
    }
  for (k = 0; k < LONGS_PER_CHARSET; k++)
    {
      long t = p[k];

      p[k] &= ~q[k];
      q[k] = t & q[k];
    }
  while (!scm_is_null (rest))
    {
      SCM cs = SCM_CAR (rest);
      long *r;

      SCM_VALIDATE_SMOB (c, cs, charset);
      c++;
      r = (long *) SCM_SMOB_DATA (cs);

      for (k = 0; k < LONGS_PER_CHARSET; k++)
	{
	  q[k] |= p[k] & r[k];
	  p[k] &= ~r[k];
	}
      rest = SCM_CDR (rest);
    }
  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_full;

/* Create an empty character set and return it after binding it to NAME.  */
static inline SCM
define_charset (const char *name)
{
  SCM cs = make_char_set (NULL);
  scm_c_define (name, cs);
  return scm_permanent_object (cs);
}

/* Membership predicates for the various char sets.

   XXX: The `punctuation' and `symbol' char sets have no direct equivalent in
   <ctype.h>.  Thus, the predicates below yield correct results for ASCII,
   but they do not provide the result described by the SRFI for Latin-1.  The
   correct Latin-1 result could only be obtained by hard-coding the
   characters listed by the SRFI, but the problem would remain for other
   8-bit charsets.

   Similarly, character 0xA0 in Latin-1 (unbreakable space, `#\0240') should
   be part of `char-set:blank'.  However, glibc's current (2006/09) Latin-1
   locales (which use the ISO 14652 "i18n" FDCC-set) do not consider it
   `blank' so it ends up in `char-set:punctuation'.  */
#ifdef HAVE_ISBLANK
# define CSET_BLANK_PRED(c)  (isblank (c))
#else
# define CSET_BLANK_PRED(c)			\
   (((c) == ' ') || ((c) == '\t'))
#endif

#define CSET_SYMBOL_PRED(c)					\
  (((c) != '\0') && (strchr ("$+<=>^`|~", (c)) != NULL))
#define CSET_PUNCT_PRED(c)					\
  ((ispunct (c)) && (!CSET_SYMBOL_PRED (c)))

#define CSET_LOWER_PRED(c)       (islower (c))
#define CSET_UPPER_PRED(c)       (isupper (c))
#define CSET_LETTER_PRED(c)      (isalpha (c))
#define CSET_DIGIT_PRED(c)       (isdigit (c))
#define CSET_WHITESPACE_PRED(c)  (isspace (c))
#define CSET_CONTROL_PRED(c)     (iscntrl (c))
#define CSET_HEX_DIGIT_PRED(c)   (isxdigit (c))
#define CSET_ASCII_PRED(c)       (isascii (c))

/* Some char sets are explicitly defined by the SRFI as a union of other char
   sets so we try to follow this closely.  */

#define CSET_LETTER_AND_DIGIT_PRED(c)		\
  (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c))

#define CSET_GRAPHIC_PRED(c)				\
  (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c)		\
   || CSET_PUNCT_PRED (c) || CSET_SYMBOL_PRED (c))

#define CSET_PRINTING_PRED(c)				\
  (CSET_GRAPHIC_PRED (c) || CSET_WHITESPACE_PRED (c))

/* False and true predicates.  */
#define CSET_TRUE_PRED(c)    (1)
#define CSET_FALSE_PRED(c)   (0)

/* Compute the contents of all the standard character sets.  Computation may
   need to be re-done at `setlocale'-time because some char sets (e.g.,
   `char-set:letter') need to reflect the character set supported by Guile.

   For instance, at startup time, the "C" locale is used, thus Guile supports
   only ASCII; therefore, `char-set:letter' only contains English letters.
   The user can change this by invoking `setlocale' and specifying a locale
   with an 8-bit charset, thereby augmenting some of the SRFI-14 standard
   character sets.

   This works because some of the predicates used below to construct
   character sets (e.g., `isalpha(3)') are locale-dependent (so
   charset-dependent, though generally not language-dependent).  For details,
   please see the `guile-devel' mailing list archive of September 2006.  */
void
scm_srfi_14_compute_char_sets (void)
{
#define UPDATE_CSET(c, cset, pred)		\
  do						\
    {						\
      if (pred (c))				\
	SCM_CHARSET_SET ((cset), (c));		\
      else					\
	SCM_CHARSET_UNSET ((cset), (c));	\
    }						\
  while (0)

  register int ch;

  for (ch = 0; ch < 256; ch++)
    {
      UPDATE_CSET (ch, scm_char_set_upper_case, CSET_UPPER_PRED);
      UPDATE_CSET (ch, scm_char_set_lower_case, CSET_LOWER_PRED);
      UPDATE_CSET (ch, scm_char_set_title_case, CSET_FALSE_PRED);
      UPDATE_CSET (ch, scm_char_set_letter, CSET_LETTER_PRED);
      UPDATE_CSET (ch, scm_char_set_digit, CSET_DIGIT_PRED);
      UPDATE_CSET (ch, scm_char_set_letter_and_digit,
		   CSET_LETTER_AND_DIGIT_PRED);
      UPDATE_CSET (ch, scm_char_set_graphic, CSET_GRAPHIC_PRED);
      UPDATE_CSET (ch, scm_char_set_printing, CSET_PRINTING_PRED);
      UPDATE_CSET (ch, scm_char_set_whitespace, CSET_WHITESPACE_PRED);
      UPDATE_CSET (ch, scm_char_set_iso_control, CSET_CONTROL_PRED);
      UPDATE_CSET (ch, scm_char_set_punctuation, CSET_PUNCT_PRED);
      UPDATE_CSET (ch, scm_char_set_symbol, CSET_SYMBOL_PRED);
      UPDATE_CSET (ch, scm_char_set_hex_digit, CSET_HEX_DIGIT_PRED);
      UPDATE_CSET (ch, scm_char_set_blank, CSET_BLANK_PRED);
      UPDATE_CSET (ch, scm_char_set_ascii, CSET_ASCII_PRED);
      UPDATE_CSET (ch, scm_char_set_empty, CSET_FALSE_PRED);
      UPDATE_CSET (ch, scm_char_set_full, CSET_TRUE_PRED);
    }

#undef UPDATE_CSET
}

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

  scm_char_set_upper_case = define_charset ("char-set:upper-case");
  scm_char_set_lower_case = define_charset ("char-set:lower-case");
  scm_char_set_title_case = define_charset ("char-set:title-case");
  scm_char_set_letter = define_charset ("char-set:letter");
  scm_char_set_digit = define_charset ("char-set:digit");
  scm_char_set_letter_and_digit = define_charset ("char-set:letter+digit");
  scm_char_set_graphic = define_charset ("char-set:graphic");
  scm_char_set_printing = define_charset ("char-set:printing");
  scm_char_set_whitespace = define_charset ("char-set:whitespace");
  scm_char_set_iso_control = define_charset ("char-set:iso-control");
  scm_char_set_punctuation = define_charset ("char-set:punctuation");
  scm_char_set_symbol = define_charset ("char-set:symbol");
  scm_char_set_hex_digit = define_charset ("char-set:hex-digit");
  scm_char_set_blank = define_charset ("char-set:blank");
  scm_char_set_ascii = define_charset ("char-set:ascii");
  scm_char_set_empty = define_charset ("char-set:empty");
  scm_char_set_full = define_charset ("char-set:full");

  scm_srfi_14_compute_char_sets ();

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

#include "libguile/__scm.h"

#define SCM_CHARSET_SIZE 256

/* We expect 8-bit bytes here.  Should be no problem in the year
   2001.  */
#ifndef SCM_BITS_PER_LONG
# define SCM_BITS_PER_LONG (sizeof (long) * 8)
#endif

#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\
			           [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\
			 	   (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG)))

#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_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_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_API void scm_srfi_14_compute_char_sets (void);
SCM_API void scm_init_srfi_14 (void);

#endif /* SCM_SRFI_14_H */


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

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

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

#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/srfi-4.h"
#include "libguile/error.h"
#include "libguile/read.h"
#include "libguile/ports.h"
#include "libguile/chars.h"
#include "libguile/vectors.h"
#include "libguile/unif.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"

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

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

/* Smob type code for uniform numeric vectors.  */
int scm_tc16_uvec = 0;

#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))

/* Accessor macros for the three components of a uniform numeric
   vector:
   - The type tag (one of the symbolic constants below).
   - The vector's length (counted in elements).
   - The address of the data area (holding the elements of the
     vector). */
#define SCM_UVEC_TYPE(u)   (SCM_CELL_WORD_1(u))
#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
#define SCM_UVEC_BASE(u)   ((void *)SCM_CELL_WORD_3(u))

/* Symbolic constants encoding the various types of uniform
   numeric vectors.  */
#define SCM_UVEC_U8  	0
#define SCM_UVEC_S8  	1
#define SCM_UVEC_U16 	2
#define SCM_UVEC_S16 	3
#define SCM_UVEC_U32 	4
#define SCM_UVEC_S32 	5
#define SCM_UVEC_U64 	6
#define SCM_UVEC_S64 	7
#define SCM_UVEC_F32 	8
#define SCM_UVEC_F64 	9
#define SCM_UVEC_C32   10
#define SCM_UVEC_C64   11

/* This array maps type tags to the size of the elements.  */
static const int uvec_sizes[12] = {
  1, 1,
  2, 2,
  4, 4,
  8, 8,
  sizeof(float), sizeof(double),
  2*sizeof(float), 2*sizeof(double)
};

static const char *uvec_tags[12] = {
  "u8", "s8",
  "u16", "s16",
  "u32", "s32",
  "u64", "s64",
  "f32", "f64",
  "c32", "c64",
};

static const char *uvec_names[12] = {
  "u8vector", "s8vector",
  "u16vector", "s16vector",
  "u32vector", "s32vector",
  "u64vector", "s64vector",
  "f32vector", "f64vector",
  "c32vector", "c64vector"
};

/* ================================================================ */
/* SMOB procedures.                                                 */
/* ================================================================ */

/* Smob print hook for uniform vectors.  */
static int
uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
{
  union {
    scm_t_uint8 *u8;
    scm_t_int8 *s8;
    scm_t_uint16 *u16;
    scm_t_int16 *s16;
    scm_t_uint32 *u32;
    scm_t_int32 *s32;
    scm_t_uint64 *u64;
    scm_t_int64 *s64;
    float *f32;
    double *f64;
    SCM *fake_64;
  } np;

  size_t i = 0;
  const size_t uvlen = SCM_UVEC_LENGTH (uvec);
  void *uptr = SCM_UVEC_BASE (uvec);

  switch (SCM_UVEC_TYPE (uvec))
  {
    case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
    case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
    case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
    case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
    case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
    case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
    case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
    case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
    case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
    case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
    case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
    case SCM_UVEC_C64: np.f64 = (double *) uptr; break;
    default:
      abort ();			/* Sanity check.  */
      break;
  }

  scm_putc ('#', port);
  scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
  scm_putc ('(', port);

  while (i < uvlen)
    {
      if (i != 0) scm_puts (" ", port);
      switch (SCM_UVEC_TYPE (uvec))
	{
	case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
	case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
	case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
	case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
	case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
	case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
	case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
	case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
	case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
	case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
	case SCM_UVEC_C32:
	  scm_i_print_complex (np.f32[0], np.f32[1], port);
	  np.f32 += 2;
	  break;
	case SCM_UVEC_C64:
	  scm_i_print_complex (np.f64[0], np.f64[1], port);
	  np.f64 += 2;
	  break;
	default:
	  abort ();			/* Sanity check.  */
	  break;
	}
      i++;
    }
  scm_remember_upto_here_1 (uvec);
  scm_puts (")", port);
  return 1;
}

const char *
scm_i_uniform_vector_tag (SCM uvec)
{
  return uvec_tags[SCM_UVEC_TYPE (uvec)];
}

static SCM
uvec_equalp (SCM a, SCM b)
{
  SCM result = SCM_BOOL_T;
  if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
    result = SCM_BOOL_F;
  else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
    result = SCM_BOOL_F;
  else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
		   SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
    result = SCM_BOOL_F;

  scm_remember_upto_here_2 (a, b);
  return result;
}

/* Smob free hook for uniform numeric vectors. */
static size_t
uvec_free (SCM uvec)
{
  int type = SCM_UVEC_TYPE (uvec);
  scm_gc_free (SCM_UVEC_BASE (uvec),
	       SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
	       uvec_names[type]);
  return 0;
}

/* ================================================================ */
/* Utility procedures.                                              */
/* ================================================================ */

static SCM_C_INLINE_KEYWORD int
is_uvec (int type, SCM obj)
{
  if (SCM_IS_UVEC (obj))
    return SCM_UVEC_TYPE (obj) == type;
  if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
    {
      SCM v = SCM_I_ARRAY_V (obj);
      return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
    }
  return 0;
}

static SCM_C_INLINE_KEYWORD SCM
uvec_p (int type, SCM obj)
{
  return scm_from_bool (is_uvec (type, obj));
}

static SCM_C_INLINE_KEYWORD void
uvec_assert (int type, SCM obj)
{
  if (!is_uvec (type, obj))
    scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
}

static SCM
take_uvec (int type, void *base, size_t len)
{
  SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
}

/* Create a new, uninitialized uniform numeric vector of type TYPE
   with space for LEN elements.  */
static SCM
alloc_uvec (int type, size_t len)
{
  void *base;
  if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
    scm_out_of_range (NULL, scm_from_size_t (len));
  base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
  return take_uvec (type, base, len);
}

/* GCC doesn't seem to want to optimize unused switch clauses away,
   so we use a big 'if' in the next two functions.
*/

static SCM_C_INLINE_KEYWORD SCM
uvec_fast_ref (int type, const void *base, size_t c_idx)
{
  if (type == SCM_UVEC_U8)
    return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
  else if (type == SCM_UVEC_S8)
    return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
  else if (type == SCM_UVEC_U16)
    return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
  else if (type == SCM_UVEC_S16)
    return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
  else if (type == SCM_UVEC_U32)
    return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
  else if (type == SCM_UVEC_S32)
    return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
  else if (type == SCM_UVEC_U64)
    return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
  else if (type == SCM_UVEC_S64)
    return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
  else if (type == SCM_UVEC_F32)
    return scm_from_double (((float*)base)[c_idx]);
  else if (type == SCM_UVEC_F64)
    return scm_from_double (((double*)base)[c_idx]);
  else if (type == SCM_UVEC_C32)
    return scm_c_make_rectangular (((float*)base)[2*c_idx],
				   ((float*)base)[2*c_idx+1]);
  else if (type == SCM_UVEC_C64)
    return scm_c_make_rectangular (((double*)base)[2*c_idx],
				   ((double*)base)[2*c_idx+1]);
  else
    return SCM_BOOL_F;
}

static SCM_C_INLINE_KEYWORD void
uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
{
  if (type == SCM_UVEC_U8)
    (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
  else if (type == SCM_UVEC_S8)
    (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
  else if (type == SCM_UVEC_U16)
    (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
  else if (type == SCM_UVEC_S16)
    (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
  else if (type == SCM_UVEC_U32)
    (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
  else if (type == SCM_UVEC_S32)
    (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
  else if (type == SCM_UVEC_U64)
    (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
  else if (type == SCM_UVEC_S64)
    (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
  else if (type == SCM_UVEC_F32)
    (((float*)base)[c_idx]) = scm_to_double (val);
  else if (type == SCM_UVEC_F64)
    (((double*)base)[c_idx]) = scm_to_double (val);
  else if (type == SCM_UVEC_C32)
    {
      (((float*)base)[2*c_idx])   = scm_c_real_part (val);
      (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
    }
  else if (type == SCM_UVEC_C64)
    {
      (((double*)base)[2*c_idx])   = scm_c_real_part (val);
      (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
    }
}

static SCM_C_INLINE_KEYWORD SCM
make_uvec (int type, SCM len, SCM fill)
{
  size_t c_len = scm_to_size_t (len);
  SCM uvec = alloc_uvec (type, c_len);
  if (!SCM_UNBNDP (fill))
    {
      size_t idx;
      void *base = SCM_UVEC_BASE (uvec);
      for (idx = 0; idx < c_len; idx++)
	uvec_fast_set_x (type, base, idx, fill);
    }
  return uvec;
}

static SCM_C_INLINE_KEYWORD void *
uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
			size_t *lenp, ssize_t *incp)
{
  if (type >= 0)
    {
      SCM v = uvec;
      if (SCM_I_ARRAYP (v))
	v = SCM_I_ARRAY_V (v);
      uvec_assert (type, v);
    }

  return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
}

static SCM_C_INLINE_KEYWORD const void *
uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
	       size_t *lenp, ssize_t *incp)
{
  return uvec_writable_elements (type, uvec, handle, lenp, incp);
}

static int
uvec_type (scm_t_array_handle *h)
{
  SCM v = h->array;
  if (SCM_I_ARRAYP (v))
    v = SCM_I_ARRAY_V (v);
  return SCM_UVEC_TYPE (v);
}

static SCM
uvec_to_list (int type, SCM uvec)
{
  scm_t_array_handle handle;
  size_t len;
  ssize_t i, inc;
  const void *elts;
  SCM res = SCM_EOL;

  elts = uvec_elements (type, uvec, &handle, &len, &inc);
  for (i = len*inc; i > 0;)
    {
      i -= inc;
      res = scm_cons (scm_array_handle_ref (&handle, i), res);
    }
  scm_array_handle_release (&handle);
  return res;
}

static SCM_C_INLINE_KEYWORD SCM
uvec_length (int type, SCM uvec)
{
  scm_t_array_handle handle;
  size_t len;
  ssize_t inc;
  uvec_elements (type, uvec, &handle, &len, &inc);
  scm_array_handle_release (&handle);
  return scm_from_size_t (len);
}

static SCM_C_INLINE_KEYWORD SCM
uvec_ref (int type, SCM uvec, SCM idx)
{
  scm_t_array_handle handle;
  size_t i, len;
  ssize_t inc;
  const void *elts;
  SCM res;

  elts = uvec_elements (type, uvec, &handle, &len, &inc);
  if (type < 0)
    type = uvec_type (&handle);
  i = scm_to_unsigned_integer (idx, 0, len-1);
  res = uvec_fast_ref (type, elts, i*inc);
  scm_array_handle_release (&handle);
  return res;
}

static SCM_C_INLINE_KEYWORD SCM
uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
{
  scm_t_array_handle handle;
  size_t i, len;
  ssize_t inc;
  void *elts;

  elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
  if (type < 0)
    type = uvec_type (&handle);
  i = scm_to_unsigned_integer (idx, 0, len-1);
  uvec_fast_set_x (type, elts, i*inc, val);
  scm_array_handle_release (&handle);
  return SCM_UNSPECIFIED;
}

static SCM_C_INLINE_KEYWORD SCM
list_to_uvec (int type, SCM list)
{
  SCM uvec;
  void *base;
  long idx;
  long len = scm_ilength (list);
  if (len < 0)
    scm_wrong_type_arg_msg (NULL, 0, list, "proper list");

  uvec = alloc_uvec (type, len);
  base = SCM_UVEC_BASE (uvec);
  idx = 0;
  while (scm_is_pair (list) && idx < len)
    {
      uvec_fast_set_x (type, base, idx, SCM_CAR (list));
      list = SCM_CDR (list);
      idx++;
    }
  return uvec;
}

static SCM
coerce_to_uvec (int type, SCM obj)
{
  if (is_uvec (type, obj))
    return obj;
  else if (scm_is_pair (obj))
    return list_to_uvec (type, obj);
  else if (scm_is_generalized_vector (obj))
    {
      scm_t_array_handle handle;
      size_t len = scm_c_generalized_vector_length (obj), i;
      SCM uvec = alloc_uvec (type, len);
      scm_array_get_handle (uvec, &handle);
      for (i = 0; i < len; i++)
	scm_array_handle_set (&handle, i,
			      scm_c_generalized_vector_ref (obj, i));
      scm_array_handle_release (&handle);
      return uvec;
    }
  else
    scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
}

SCM_SYMBOL (scm_sym_a, "a");
SCM_SYMBOL (scm_sym_b, "b");

SCM
scm_i_generalized_vector_type (SCM v)
{
  if (scm_is_vector (v))
    return SCM_BOOL_T;
  else if (scm_is_string (v))
    return scm_sym_a;
  else if (scm_is_bitvector (v))
    return scm_sym_b;
  else if (scm_is_uniform_vector (v))
    return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
  else
    return SCM_BOOL_F;
}

int
scm_is_uniform_vector (SCM obj)
{
  if (SCM_IS_UVEC (obj))
    return 1;
  if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
    {
      SCM v = SCM_I_ARRAY_V (obj);
      return SCM_IS_UVEC (v);
    }
  return 0;
}

size_t
scm_c_uniform_vector_length (SCM uvec)
{
  /* scm_generalized_vector_get_handle will ultimately call us to get
     the length of uniform vectors, so we can't use uvec_elements for
     naked vectors.
  */

  if (SCM_IS_UVEC (uvec))
    return SCM_UVEC_LENGTH (uvec);
  else
    {
      scm_t_array_handle handle;
      size_t len;
      ssize_t inc;
      uvec_elements (-1, uvec, &handle, &len, &inc);
      scm_array_handle_release (&handle);
      return len;
    }
}

SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a uniform vector.")
#define FUNC_NAME s_scm_uniform_vector_p
{
  return scm_from_bool (scm_is_uniform_vector (obj));
}
#undef FUNC_NAME

SCM
scm_c_uniform_vector_ref (SCM v, size_t idx)
{
  scm_t_array_handle handle;
  size_t len;
  ssize_t inc;
  SCM res;

  uvec_elements (-1, v, &handle, &len, &inc);
  if (idx >= len)
    scm_out_of_range (NULL, scm_from_size_t (idx));
  res = scm_array_handle_ref (&handle, idx*inc);
  scm_array_handle_release (&handle);
  return res;
}

SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
	    (SCM v, SCM idx),
	    "Return the element at index @var{idx} of the\n"
	    "homogenous numeric vector @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_ref
{
#if SCM_ENABLE_DEPRECATED
  /* Support old argument convention.
   */
  if (scm_is_pair (idx))
    {
      scm_c_issue_deprecation_warning
	("Using a list as the index to uniform-vector-ref is deprecated.");
      if (!scm_is_null (SCM_CDR (idx)))
	scm_wrong_num_args (NULL);
      idx = SCM_CAR (idx);
    }
#endif

  return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
}
#undef FUNC_NAME

void
scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
{
  scm_t_array_handle handle;
  size_t len;
  ssize_t inc;

  uvec_writable_elements (-1, v, &handle, &len, &inc);
  if (idx >= len)
    scm_out_of_range (NULL, scm_from_size_t (idx));
  scm_array_handle_set (&handle, idx*inc, val);
  scm_array_handle_release (&handle);
}

SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
	    (SCM v, SCM idx, SCM val),
	    "Set the element at index @var{idx} of the\n"
	    "homogenous numeric vector @var{v} to @var{val}.")
#define FUNC_NAME s_scm_uniform_vector_set_x
{
#if SCM_ENABLE_DEPRECATED
  /* Support old argument convention.
   */
  if (scm_is_pair (idx))
    {
      scm_c_issue_deprecation_warning
	("Using a list as the index to uniform-vector-set! is deprecated.");
      if (!scm_is_null (SCM_CDR (idx)))
	scm_wrong_num_args (NULL);
      idx = SCM_CAR (idx);
    }
#endif

  scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
            (SCM uvec),
	    "Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_scm_uniform_vector_to_list
{
  return uvec_to_list (-1, uvec);
}
#undef FUNC_NAME

size_t
scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
  SCM vec = h->array;
  if (SCM_I_ARRAYP (vec))
    vec = SCM_I_ARRAY_V (vec);
  if (scm_is_uniform_vector (vec))
    return uvec_sizes[SCM_UVEC_TYPE(vec)];
  scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}

#if SCM_ENABLE_DEPRECATED

/* return the size of an element in a uniform array or 0 if type not
   found.  */
size_t
scm_uniform_element_size (SCM obj)
{
  scm_c_issue_deprecation_warning
    ("scm_uniform_element_size is deprecated.  "
     "Use scm_array_handle_uniform_element_size instead.");

  if (SCM_IS_UVEC (obj))
    return uvec_sizes[SCM_UVEC_TYPE(obj)];
  else
    return 0;
}

#endif

const void *
scm_array_handle_uniform_elements (scm_t_array_handle *h)
{
  return scm_array_handle_uniform_writable_elements (h);
}

void *
scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
  SCM vec = h->array;
  if (SCM_I_ARRAYP (vec))
    vec = SCM_I_ARRAY_V (vec);
  if (SCM_IS_UVEC (vec))
    {
      size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
      char *elts = SCM_UVEC_BASE (vec);
      return (void *) (elts + size*h->base);
    }
  scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}

const void *
scm_uniform_vector_elements (SCM uvec,
			     scm_t_array_handle *h,
			     size_t *lenp, ssize_t *incp)
{
  return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
}

void *
scm_uniform_vector_writable_elements (SCM uvec,
				      scm_t_array_handle *h,
				      size_t *lenp, ssize_t *incp)
{
  scm_generalized_vector_get_handle (uvec, h);
  if (lenp)
    {
      scm_t_array_dim *dim = scm_array_handle_dims (h);
      *lenp = dim->ubnd - dim->lbnd + 1;
      *incp = dim->inc;
    }
  return scm_array_handle_uniform_writable_elements (h);
}

SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
	    (SCM v),
	    "Return the number of elements in the uniform vector @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_length
{
  return uvec_length (-1, v);
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
           (SCM uvec, SCM port_or_fd, SCM start, SCM end),
	    "Fill the elements of @var{uvec} by reading\n"
	    "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
	    "The optional arguments @var{start} (inclusive) and @var{end}\n"
	    "(exclusive) allow a specified region to be read,\n"
	    "leaving the remainder of the vector unchanged.\n\n"
	    "When @var{port-or-fdes} is a port, all specified elements\n"
	    "of @var{uvec} are attempted to be read, potentially blocking\n"
	    "while waiting formore input or end-of-file.\n"
	    "When @var{port-or-fd} is an integer, a single call to\n"
	    "read(2) is made.\n\n"
	    "An error is signalled when the last element has only\n"
	    "been partially filled before reaching end-of-file or in\n"
	    "the single call to read(2).\n\n"
	    "@code{uniform-vector-read!} returns the number of elements\n"
	    "read.\n\n"
	    "@var{port-or-fdes} may be omitted, in which case it defaults\n"
	    "to the value returned by @code{(current-input-port)}.")
#define FUNC_NAME s_scm_uniform_vector_read_x
{
  scm_t_array_handle handle;
  size_t vlen, sz, ans;
  ssize_t inc;
  size_t cstart, cend;
  size_t remaining, off;
  char *base;

  if (SCM_UNBNDP (port_or_fd))
    port_or_fd = scm_current_input_port ();
  else
    SCM_ASSERT (scm_is_integer (port_or_fd)
		|| (SCM_OPINPORTP (port_or_fd)),
		port_or_fd, SCM_ARG2, FUNC_NAME);

  if (!scm_is_uniform_vector (uvec))
    scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");

  base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
  sz = scm_array_handle_uniform_element_size (&handle);

  if (inc != 1)
    {
      /* XXX - we should of course support non contiguous vectors. */
      scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
		      scm_list_1 (uvec));
    }

  cstart = 0;
  cend = vlen;
  if (!SCM_UNBNDP (start))
    {
      cstart = scm_to_unsigned_integer (start, 0, vlen);
      if (!SCM_UNBNDP (end))
	cend = scm_to_unsigned_integer (end, cstart, vlen);
    }

  remaining = (cend - cstart) * sz;
  off = cstart * sz;

  if (SCM_NIMP (port_or_fd))
    {
      ans = cend - cstart;
      remaining -= scm_c_read (port_or_fd, base + off, remaining);
      if (remaining % sz != 0)
        SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
      ans -= remaining / sz;
    }
  else /* file descriptor.  */
    {
      int fd = scm_to_int (port_or_fd);
      int n;

      SCM_SYSCALL (n = read (fd, base + off, remaining));
      if (n == -1)
	SCM_SYSERROR;
      if (n % sz != 0)
	SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
      ans = n / sz;
    }

  scm_array_handle_release (&handle);

  return scm_from_size_t (ans);
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
           (SCM uvec, SCM port_or_fd, SCM start, SCM end),
	    "Write the elements of @var{uvec} as raw bytes to\n"
	    "@var{port-or-fdes}, in the host byte order.\n\n"
	    "The optional arguments @var{start} (inclusive)\n"
	    "and @var{end} (exclusive) allow\n"
	    "a specified region to be written.\n\n"
	    "When @var{port-or-fdes} is a port, all specified elements\n"
	    "of @var{uvec} are attempted to be written, potentially blocking\n"
	    "while waiting for more room.\n"
	    "When @var{port-or-fd} is an integer, a single call to\n"
	    "write(2) is made.\n\n"
	    "An error is signalled when the last element has only\n"
	    "been partially written in the single call to write(2).\n\n"
	    "The number of objects actually written is returned.\n"
	    "@var{port-or-fdes} may be\n"
	    "omitted, in which case it defaults to the value returned by\n"
	    "@code{(current-output-port)}.")
#define FUNC_NAME s_scm_uniform_vector_write
{
  scm_t_array_handle handle;
  size_t vlen, sz, ans;
  ssize_t inc;
  size_t cstart, cend;
  size_t amount, off;
  const char *base;

  port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);

  if (SCM_UNBNDP (port_or_fd))
    port_or_fd = scm_current_output_port ();
  else
    SCM_ASSERT (scm_is_integer (port_or_fd)
		|| (SCM_OPOUTPORTP (port_or_fd)),
		port_or_fd, SCM_ARG2, FUNC_NAME);

  base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
  sz = scm_array_handle_uniform_element_size (&handle);

  if (inc != 1)
    {
      /* XXX - we should of course support non contiguous vectors. */
      scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
		      scm_list_1 (uvec));
    }

  cstart = 0;
  cend = vlen;
  if (!SCM_UNBNDP (start))
    {
      cstart = scm_to_unsigned_integer (start, 0, vlen);
      if (!SCM_UNBNDP (end))
	cend = scm_to_unsigned_integer (end, cstart, vlen);
    }

  amount = (cend - cstart) * sz;
  off = cstart * sz;

  if (SCM_NIMP (port_or_fd))
    {
      scm_lfwrite (base + off, amount, port_or_fd);
      ans = cend - cstart;
    }
  else /* file descriptor.  */
    {
      int fd = scm_to_int (port_or_fd), n;
      SCM_SYSCALL (n = write (fd, base + off, amount));
      if (n == -1)
	SCM_SYSERROR;
      if (n % sz != 0)
	SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
      ans = n / sz;
    }

  scm_array_handle_release (&handle);

  return scm_from_size_t (ans);
}
#undef FUNC_NAME

/* ================================================================ */
/* Exported procedures.                                             */
/* ================================================================ */

#define TYPE  SCM_UVEC_U8
#define TAG   u8
#define CTYPE scm_t_uint8
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S8
#define TAG   s8
#define CTYPE scm_t_int8
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_U16
#define TAG   u16
#define CTYPE scm_t_uint16
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S16
#define TAG   s16
#define CTYPE scm_t_int16
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_U32
#define TAG   u32
#define CTYPE scm_t_uint32
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S32
#define TAG   s32
#define CTYPE scm_t_int32
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_U64
#define TAG   u64
#define CTYPE scm_t_uint64
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S64
#define TAG   s64
#define CTYPE scm_t_int64
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_F32
#define TAG   f32
#define CTYPE float
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_F64
#define TAG   f64
#define CTYPE double
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_C32
#define TAG   c32
#define CTYPE float
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_C64
#define TAG   c64
#define CTYPE double
#include "libguile/srfi-4.i.c"

static scm_i_t_array_ref uvec_reffers[12] = {
  u8ref, s8ref,
  u16ref, s16ref,
  u32ref, s32ref,
  u64ref, s64ref,
  f32ref, f64ref,
  c32ref, c64ref
};

static scm_i_t_array_set uvec_setters[12] = {
  u8set, s8set,
  u16set, s16set,
  u32set, s32set,
  u64set, s64set,
  f32set, f64set,
  c32set, c64set
};

scm_i_t_array_ref
scm_i_uniform_vector_ref_proc (SCM uvec)
{
  return uvec_reffers[SCM_UVEC_TYPE(uvec)];
}

scm_i_t_array_set
scm_i_uniform_vector_set_proc (SCM uvec)
{
  return uvec_setters[SCM_UVEC_TYPE(uvec)];
}

void
scm_init_srfi_4 (void)
{
  scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
  scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
  scm_set_smob_free (scm_tc16_uvec, uvec_free);
  scm_set_smob_print (scm_tc16_uvec, uvec_print);

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

#include "libguile/__scm.h"
#include "libguile/unif.h"

/* Generic procedures.
 */

SCM_API SCM scm_uniform_vector_p (SCM v);
SCM_API SCM scm_uniform_vector_length (SCM v);
SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
SCM_API SCM scm_uniform_vector_to_list (SCM v);
SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
				       SCM start, SCM end);
SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
				      SCM start, SCM end);

SCM_API int scm_is_uniform_vector (SCM obj);
SCM_API size_t scm_c_uniform_vector_length (SCM v);
SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h);
SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h);
SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h);
SCM_API const void *scm_uniform_vector_elements (SCM uvec,
						 scm_t_array_handle *h,
						 size_t *lenp, ssize_t *incp);
SCM_API void *scm_uniform_vector_writable_elements (SCM uvec,
						    scm_t_array_handle *h,
						    size_t *lenp,
						    ssize_t *incp);

/* 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_API SCM scm_i_generalized_vector_type (SCM vec);
SCM_API const char *scm_i_uniform_vector_tag (SCM uvec);
SCM_API scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec);
SCM_API 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_API size_t scm_uniform_element_size (SCM obj);

#endif

SCM_API void scm_init_srfi_4 (void);

#endif /* SCM_SRFI_4_H */